From f923243cbbea98e1a1bb5a08072c64d60f5a65e2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 8 Mar 2024 15:15:51 +0000 Subject: Add Tcl_GetAlias/Tcl_GetAliasObj to TIP #616 --- doc/CrtAlias.3 | 12 ++++++++-- generic/tcl.decls | 16 ++++++++++--- generic/tclDecls.h | 65 ++++++++++++++++++++++++++++++++++++++------------- generic/tclInterp.c | 8 +++---- generic/tclStubInit.c | 42 +++++++++++++++++++++++++++++---- 5 files changed, 114 insertions(+), 29 deletions(-) diff --git a/doc/CrtAlias.3 b/doc/CrtAlias.3 index fba6253..879e07c 100644 --- a/doc/CrtAlias.3 +++ b/doc/CrtAlias.3 @@ -87,16 +87,24 @@ command is defined for an alias. .AP "const char" **targetCmdPtr out Pointer to location to store the address of the name of the target command for an alias. -.AP int *argcPtr out +.AP "Tcl_Size \&| int" *argcPtr out Pointer to location to store count of additional arguments to be passed to the alias. The location is in storage owned by the caller. +If it points to a variable which type is not \fBTcl_Size\fR, a compiler +warning will be generated. If your extensions is compiled with -DTCL_8_API, +this function will return TCL_ERROR for aliases with more than INT_MAX +value arguments, otherwise expect it to crash. .AP "const char" ***argvPtr out Pointer to location to store a vector of strings, the additional arguments to pass to an alias. The location is in storage owned by the caller, the vector of strings is owned by the called function. -.AP int *objcPtr out +.AP "Tcl_Size \&| int" *objcPtr out Pointer to location to store count of additional value arguments to be passed to the alias. The location is in storage owned by the caller. +If it points to a variable which type is not \fBTcl_Size\fR, a compiler +warning will be generated. If your extensions is compiled with -DTCL_8_API, +this function will return TCL_ERROR for aliases with more than INT_MAX +value arguments, otherwise expect it to crash .AP Tcl_Obj ***objvPtr out Pointer to location to store a vector of Tcl_Obj structures, the additional arguments to pass to an alias command. The location is in storage diff --git a/generic/tcl.decls b/generic/tcl.decls index 5f82a1c..bdc581c 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -463,6 +463,11 @@ declare 142 { declare 143 { void Tcl_Finalize(void) } +declare 144 { + int Tcl_GetAlias(Tcl_Interp *interp, const char *childCmd, + Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, + Tcl_Size *argcPtr, const char ***argvPtr) +} declare 145 { Tcl_HashEntry *Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr) @@ -470,15 +475,20 @@ declare 145 { declare 146 { int Tcl_Flush(Tcl_Channel chan) } +declare 147 { + int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd, + Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, + Tcl_Size *objcPtr, Tcl_Obj ***objvPtr) +} declare 148 { - int Tcl_GetAlias(Tcl_Interp *interp, const char *childCmd, + int TclGetAlias(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr) } declare 149 { - int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd, + int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, - int *objcPtr, Tcl_Obj ***objv) + int *objcPtr, Tcl_Obj ***objvPtr) } declare 150 { void *Tcl_GetAssocData(Tcl_Interp *interp, const char *name, diff --git a/generic/tclDecls.h b/generic/tclDecls.h index a2b0ec1..307699b 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -420,25 +420,34 @@ EXTERN int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, EXTERN int Tcl_ExprString(Tcl_Interp *interp, const char *expr); /* 143 */ EXTERN void Tcl_Finalize(void); -/* Slot 144 is reserved */ +/* 144 */ +EXTERN int Tcl_GetAlias(Tcl_Interp *interp, + const char *childCmd, + Tcl_Interp **targetInterpPtr, + const char **targetCmdPtr, Tcl_Size *argcPtr, + const char ***argvPtr); /* 145 */ EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 146 */ EXTERN int Tcl_Flush(Tcl_Channel chan); -/* Slot 147 is reserved */ -/* 148 */ -EXTERN int Tcl_GetAlias(Tcl_Interp *interp, +/* 147 */ +EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, + const char **targetCmdPtr, Tcl_Size *objcPtr, + Tcl_Obj ***objvPtr); +/* 148 */ +EXTERN int TclGetAlias(Tcl_Interp *interp, const char *childCmd, + Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 149 */ -EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, +EXTERN int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, - Tcl_Obj ***objv); + Tcl_Obj ***objvPtr); /* 150 */ EXTERN void * Tcl_GetAssocData(Tcl_Interp *interp, const char *name, @@ -2023,12 +2032,12 @@ typedef struct TclStubs { int (*tcl_ExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 141 */ int (*tcl_ExprString) (Tcl_Interp *interp, const char *expr); /* 142 */ void (*tcl_Finalize) (void); /* 143 */ - void (*reserved144)(void); + int (*tcl_GetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, Tcl_Size *argcPtr, const char ***argvPtr); /* 144 */ Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */ int (*tcl_Flush) (Tcl_Channel chan); /* 146 */ - void (*reserved147)(void); - int (*tcl_GetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */ - int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ + int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); /* 147 */ + int (*tclGetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */ + int (*tclGetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 149 */ void * (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */ Tcl_Size (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */ @@ -2854,16 +2863,18 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ExprString) /* 142 */ #define Tcl_Finalize \ (tclStubsPtr->tcl_Finalize) /* 143 */ -/* Slot 144 is reserved */ +#define Tcl_GetAlias \ + (tclStubsPtr->tcl_GetAlias) /* 144 */ #define Tcl_FirstHashEntry \ (tclStubsPtr->tcl_FirstHashEntry) /* 145 */ #define Tcl_Flush \ (tclStubsPtr->tcl_Flush) /* 146 */ -/* Slot 147 is reserved */ -#define Tcl_GetAlias \ - (tclStubsPtr->tcl_GetAlias) /* 148 */ #define Tcl_GetAliasObj \ - (tclStubsPtr->tcl_GetAliasObj) /* 149 */ + (tclStubsPtr->tcl_GetAliasObj) /* 147 */ +#define TclGetAlias \ + (tclStubsPtr->tclGetAlias) /* 148 */ +#define TclGetAliasObj \ + (tclStubsPtr->tclGetAliasObj) /* 149 */ #define Tcl_GetAssocData \ (tclStubsPtr->tcl_GetAssocData) /* 150 */ #define Tcl_GetChannel \ @@ -4159,7 +4170,7 @@ extern const TclStubs *tclStubsPtr; #endif #ifdef USE_TCL_STUBS - /* Protect those 10 functions, make them useless through the stub table */ + /* Protect those 12 functions, make them useless through the stub table */ # undef TclGetStringFromObj # undef TclGetBytesFromObj # undef TclGetUnicodeFromObj @@ -4170,6 +4181,8 @@ extern const TclStubs *tclStubsPtr; # undef TclSplitPath # undef TclFSSplitPath # undef TclParseArgsObjv +# undef TclGetAlias +# undef TclGetAliasObj #endif #if TCL_MAJOR_VERSION < 9 @@ -4216,6 +4229,12 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_ParseArgsObjv # define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) \ tclStubsPtr->tclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) +# undef Tcl_GetAlias +# define Tcl_GetAlias(interp, childCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr) \ + tclStubsPtr->tclGetAlias((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (argcPtr), (argvPtr)) +# undef Tcl_GetAliasObj +# define Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) \ + tclStubsPtr->tclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv)) #elif defined(TCL_8_API) # undef Tcl_GetByteArrayFromObj # undef Tcl_GetBytesFromObj @@ -4228,6 +4247,8 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_SplitPath # undef Tcl_FSSplitPath # undef Tcl_ParseArgsObjv +# undef Tcl_GetAlias +# undef Tcl_GetAliasObj # if !defined(USE_TCL_STUBS) # define Tcl_GetByteArrayFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ TclGetBytesFromObj(NULL, (objPtr), (sizePtr)) : \ @@ -4262,6 +4283,12 @@ extern const TclStubs *tclStubsPtr; # define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ TclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) : \ (Tcl_ParseArgsObjv)((interp), (argTable), (Tcl_Size *)(void *)(objcPtr), (objv), (remObjv))) +# define Tcl_GetAlias(interp, childCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \ + TclGetAlias((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (argcPtr), (argvPtr)) : \ + (Tcl_GetAlias)((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (Tcl_Size *)(void *)(argcPtr), (argvPtr))) +# define Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ + TclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv)) : \ + (Tcl_GetAliasObj)((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (Tcl_Size *)(void *)(objcPtr), (objv))) # elif !defined(BUILD_tcl) # define Tcl_GetByteArrayFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetBytesFromObj(NULL, (objPtr), (sizePtr)) : \ @@ -4296,6 +4323,12 @@ extern const TclStubs *tclStubsPtr; # define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ tclStubsPtr->tclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) : \ tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (Tcl_Size *)(void *)(objcPtr), (objv), (remObjv))) +# define Tcl_GetAlias(interp, childCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \ + tclStubsPtr->tclGetAlias((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (argcPtr), (argvPtr)) : \ + tclStubsPtr->tcl_GetAlias((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (Tcl_Size *)(void *)(argcPtr), (argvPtr))) +# define Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ + tclStubsPtr->tclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv)) : \ + tclStubsPtr->tcl_GetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (Tcl_Size *)(void *)(objcPtr), (objv))) # endif /* defined(USE_TCL_STUBS) */ #else /* !defined(TCL_8_API) */ # undef Tcl_GetByteArrayFromObj diff --git a/generic/tclInterp.c b/generic/tclInterp.c index fa6cf80..5d949cf 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -1296,13 +1296,13 @@ Tcl_GetAlias( Tcl_Interp **targetInterpPtr, /* (Return) target interpreter. */ const char **targetNamePtr, /* (Return) name of target command. */ - int *argcPtr, /* (Return) count of addnl args. */ + Tcl_Size *argcPtr, /* (Return) count of addnl args. */ const char ***argvPtr) /* (Return) additional arguments. */ { InterpInfo *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; Tcl_HashEntry *hPtr; Alias *aliasPtr; - int i, objc; + Tcl_Size i, objc; Tcl_Obj **objv; hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName); @@ -1358,13 +1358,13 @@ Tcl_GetAliasObj( Tcl_Interp **targetInterpPtr, /* (Return) target interpreter. */ const char **targetNamePtr, /* (Return) name of target command. */ - int *objcPtr, /* (Return) count of addnl args. */ + Tcl_Size *objcPtr, /* (Return) count of addnl args. */ Tcl_Obj ***objvPtr) /* (Return) additional args. */ { InterpInfo *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; Tcl_HashEntry *hPtr; Alias *aliasPtr; - int objc; + Tcl_Size objc; Tcl_Obj **objv; hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName); diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 9072796..58b0465 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -98,6 +98,8 @@ # define TclSplitPath 0 # define TclFSSplitPath 0 # define TclParseArgsObjv 0 +# define TclGetAlias 0 +# define TclGetAliasObj 0 #else /* !defined(TCL_NO_DEPRECATED) */ int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, void *objcPtr, Tcl_Obj ***objvPtr) { @@ -192,6 +194,38 @@ int TclParseArgsObjv(Tcl_Interp *interp, *(int *)objcPtr = (int)n; return result; } +int TclGetAlias(Tcl_Interp *interp, const char *childCmd, + Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, + int *argcPtr, const char ***argvPtr) { + Tcl_Size n = TCL_INDEX_NONE; + int result = Tcl_GetAlias(interp, childCmd, targetInterpPtr, targetCmdPtr, &n, argvPtr); + if (argcPtr) { + if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) { + if (interp) { + Tcl_AppendResult(interp, "List too large to be processed", NULL); + } + return TCL_ERROR; + } + *argcPtr = (int)n; + } + return result; +} +int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd, + Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, + int *objcPtr, Tcl_Obj ***objv) { + Tcl_Size n = TCL_INDEX_NONE; + int result = Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, &n, objv); + if (objcPtr) { + if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) { + if (interp) { + Tcl_AppendResult(interp, "List too large to be processed", NULL); + } + return TCL_ERROR; + } + *objcPtr = (int)n; + } + return result; +} #endif /* !defined(TCL_NO_DEPRECATED) */ #define TclBN_mp_add mp_add @@ -939,12 +973,12 @@ const TclStubs tclStubs = { Tcl_ExprObj, /* 141 */ Tcl_ExprString, /* 142 */ Tcl_Finalize, /* 143 */ - 0, /* 144 */ + Tcl_GetAlias, /* 144 */ Tcl_FirstHashEntry, /* 145 */ Tcl_Flush, /* 146 */ - 0, /* 147 */ - Tcl_GetAlias, /* 148 */ - Tcl_GetAliasObj, /* 149 */ + Tcl_GetAliasObj, /* 147 */ + TclGetAlias, /* 148 */ + TclGetAliasObj, /* 149 */ Tcl_GetAssocData, /* 150 */ Tcl_GetChannel, /* 151 */ Tcl_GetChannelBufferSize, /* 152 */ -- cgit v0.12 From 64a533d813ee5b78c1511eac31f82e02b8568ba9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 20 Mar 2024 09:33:21 +0000 Subject: TIP #690 implementation: Make "clock scan -valid 1" the default --- generic/tclClock.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index 6c6ac94..96bef63 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -244,7 +244,7 @@ TclClockInit( memset(&data->lastTZOffsCache, 0, sizeof(data->lastTZOffsCache)); - data->defFlags = 0; + data->defFlags = CLF_VALIDATE; /* * Install the commands. -- cgit v0.12 From adefac1ced296669d4d00fdede83f1266b587af7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 21 Mar 2024 10:20:09 +0000 Subject: Unneeded line --- generic/tclStubInit.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index b6f8738..41b7554 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -98,7 +98,6 @@ # define TclSplitPath 0 # define TclFSSplitPath 0 # define TclParseArgsObjv 0 -# define TclGetAlias 0 # define TclGetAliasObj 0 #else /* !defined(TCL_NO_DEPRECATED) */ int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, -- cgit v0.12 From 5706177d94b4322a66c3990418043c1762b7337d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 9 Apr 2024 11:14:23 +0000 Subject: Move new Tcl_GetAliasObj() to slot 285 (old slot was used for Tcl_FreeResult() in 8.x) --- generic/tcl.decls | 13 +++++-------- generic/tclDecls.h | 24 ++++++++++++------------ generic/tclStubInit.c | 4 ++-- 3 files changed, 19 insertions(+), 22 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 2bc1934..f57eb2e 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -470,11 +470,6 @@ declare 145 { declare 146 { int Tcl_Flush(Tcl_Channel chan) } -declare 147 { - int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd, - Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, - Tcl_Size *objcPtr, Tcl_Obj ***objvPtr) -} declare 149 { int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, @@ -880,9 +875,11 @@ declare 284 { void Tcl_SetMainLoop(Tcl_MainLoopProc *proc) } -# Reserved for future use (8.0.x vs. 8.1) -# declare 285 { -# } +declare 285 { + int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd, + Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, + Tcl_Size *objcPtr, Tcl_Obj ***objvPtr) +} # Added in 8.1: diff --git a/generic/tclDecls.h b/generic/tclDecls.h index c867549..d261921 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -426,12 +426,7 @@ EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 146 */ EXTERN int Tcl_Flush(Tcl_Channel chan); -/* 147 */ -EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, - const char *childCmd, - Tcl_Interp **targetInterpPtr, - const char **targetCmdPtr, Tcl_Size *objcPtr, - Tcl_Obj ***objvPtr); +/* Slot 147 is reserved */ /* Slot 148 is reserved */ /* 149 */ EXTERN int TclGetAliasObj(Tcl_Interp *interp, @@ -761,7 +756,12 @@ EXTERN int Tcl_UnstackChannel(Tcl_Interp *interp, EXTERN Tcl_Channel Tcl_GetStackedChannel(Tcl_Channel chan); /* 284 */ EXTERN void Tcl_SetMainLoop(Tcl_MainLoopProc *proc); -/* Slot 285 is reserved */ +/* 285 */ +EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, + const char *childCmd, + Tcl_Interp **targetInterpPtr, + const char **targetCmdPtr, Tcl_Size *objcPtr, + Tcl_Obj ***objvPtr); /* 286 */ EXTERN void Tcl_AppendObjToObj(Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); @@ -2026,7 +2026,7 @@ typedef struct TclStubs { void (*reserved144)(void); Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */ int (*tcl_Flush) (Tcl_Channel chan); /* 146 */ - int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); /* 147 */ + void (*reserved147)(void); void (*reserved148)(void); int (*tclGetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 149 */ void * (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ @@ -2164,7 +2164,7 @@ typedef struct TclStubs { int (*tcl_UnstackChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 282 */ Tcl_Channel (*tcl_GetStackedChannel) (Tcl_Channel chan); /* 283 */ void (*tcl_SetMainLoop) (Tcl_MainLoopProc *proc); /* 284 */ - void (*reserved285)(void); + int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); /* 285 */ void (*tcl_AppendObjToObj) (Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); /* 286 */ Tcl_Encoding (*tcl_CreateEncoding) (const Tcl_EncodingType *typePtr); /* 287 */ void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 288 */ @@ -2859,8 +2859,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FirstHashEntry) /* 145 */ #define Tcl_Flush \ (tclStubsPtr->tcl_Flush) /* 146 */ -#define Tcl_GetAliasObj \ - (tclStubsPtr->tcl_GetAliasObj) /* 147 */ +/* Slot 147 is reserved */ /* Slot 148 is reserved */ #define TclGetAliasObj \ (tclStubsPtr->tclGetAliasObj) /* 149 */ @@ -3108,7 +3107,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetStackedChannel) /* 283 */ #define Tcl_SetMainLoop \ (tclStubsPtr->tcl_SetMainLoop) /* 284 */ -/* Slot 285 is reserved */ +#define Tcl_GetAliasObj \ + (tclStubsPtr->tcl_GetAliasObj) /* 285 */ #define Tcl_AppendObjToObj \ (tclStubsPtr->tcl_AppendObjToObj) /* 286 */ #define Tcl_CreateEncoding \ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 1d8dd7a..2dcb747 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -966,7 +966,7 @@ const TclStubs tclStubs = { 0, /* 144 */ Tcl_FirstHashEntry, /* 145 */ Tcl_Flush, /* 146 */ - Tcl_GetAliasObj, /* 147 */ + 0, /* 147 */ 0, /* 148 */ TclGetAliasObj, /* 149 */ Tcl_GetAssocData, /* 150 */ @@ -1104,7 +1104,7 @@ const TclStubs tclStubs = { Tcl_UnstackChannel, /* 282 */ Tcl_GetStackedChannel, /* 283 */ Tcl_SetMainLoop, /* 284 */ - 0, /* 285 */ + Tcl_GetAliasObj, /* 285 */ Tcl_AppendObjToObj, /* 286 */ Tcl_CreateEncoding, /* 287 */ Tcl_CreateThreadExitHandler, /* 288 */ -- cgit v0.12 From 055ae86887960b4b2258778c0e5b6d7fc95e2663 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 10 Apr 2024 15:35:05 +0000 Subject: One more TclHasInternalRep() --- generic/tclStringObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 81e6b18..73391fe 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -3193,7 +3193,7 @@ TclStringCat( binary = 0; if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) { forceUniChar = 1; - } else if ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) { + } else if ((objPtr->typePtr) && TclHasInternalRep(objPtr, &tclStringType)) { /* Prevent shimmer of non-string types. */ allowUniChar = 0; } -- cgit v0.12 -- cgit v0.12 From c31c0e64c17898357ae04a4a75b21500844cfdd7 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 10 Apr 2024 17:52:46 +0000 Subject: Start on consolidating chan related docs --- doc/chan.n | 321 ++++++++++++++++++++++++++++++++++++++++++++++--------- doc/close.n | 94 +--------------- doc/eof.n | 45 +------- doc/fblocked.n | 52 +-------- doc/fconfigure.n | 265 +-------------------------------------------- doc/fileevent.n | 136 +---------------------- doc/flush.n | 29 +---- doc/gets.n | 85 +-------------- doc/puts.n | 85 +-------------- doc/read.n | 142 +----------------------- 10 files changed, 299 insertions(+), 955 deletions(-) diff --git a/doc/chan.n b/doc/chan.n index b03d6e4..4054da6 100644 --- a/doc/chan.n +++ b/doc/chan.n @@ -33,17 +33,14 @@ otherwise. .TP \fBchan close \fIchannelName\fR ?\fIdirection\fR? . -Closes and destroys the named channel, deleting any existing event handlers -established for the channel, and returns the empty string. If \fIdirection\fR is -given, it is -.QW\fBread\fR -or -.QW\fBwrite\fR -or any unique abbreviation of those words, and only that side of the channel is -closed. I.e. a read-write channel may become read-only or write-only. -Closing a read-only channel for reading, or closing a write-only channel for -writing is the same as simply closing the channel. It is an error to close a -read-only channel for writing or to close a write-only channel for reading. +Closes and destroys the named channel deleting any existing event handlers +established for the channel. The command returns the empty string. If +\fIdirection\fR is given, it is \fBread\fR, or \fBwrite\fR, or any unique +abbreviation of those words, and only that side of the channel is closed. I.e. a +read-write channel may become read-only or write-only. Closing a read-only +channel for reading, or closing a write-only channel for writing is the same as +simply closing the channel. It is an error to close a read-only channel for +writing or to close a write-only channel for reading. .RS .PP When a channel is closed for writing, any buffered output on the channel is @@ -90,7 +87,7 @@ restores the previous behavior. .TP \fBchan configure \fIchannelName\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?... . -Configures or reports the configuration of \fIchannelName\fR. +Configures or retrieves the configuration of the channel \fIchannelName\fR. .RS .PP If no \fIoptionName\fR or \fIvalue\fR arguments are given, @@ -109,11 +106,11 @@ relevant documentation. For example, additional options are documented for .TP \fB\-blocking\fI boolean\fR . -If \fB\-blocking\fR is set to \fBtrue\fR, which is the default, reading from or -writing to the channel may cause the process to block indefinitely. Otherwise, +If \fB\-blocking\fR is set to \fBtrue\fR (default), reading the channel +or writing to it may cause the process to block indefinitely. Otherwise, operations such as \fBchan gets\fR, \fBchan read\fR, \fBchan puts\fR, \fBchan flush\fR, and \fBchan close\fR take care not to block. Non-blocking mode in -generally requires that the event loop is entered, e.g. by calling +general requires that the event loop is entered, e.g. by calling \fBTcl_DoOneEvent\fR or \fBvwait\fR or by using Tk, to give Tcl a chance to process events on the channel. .\" OPTION: -buffering @@ -135,9 +132,9 @@ connect to terminal-like devices, the default value is \fBline\fR. For any input or output buffers subsequently allocated for this channel. .\" OPTION: -encoding .TP -\fB\-encoding\fR ?\fIname\fR? +\fB\-encoding\fR \fIname\fR . -Sets the encoding of the channel. \fIname\fR is either one of the names +Sets the encoding of the channel to \fIname\fR which should be one of the names returned by \fBencoding names\fR, or .QW \fBbinary\fR \&. Input is converted from the encoding into Unicode, and output is converted @@ -194,7 +191,7 @@ end-of-line character. .RS .PP Returns the input translation for a read-only channel, the output translation -for a write-only channel, and both the input translation and the the output +for a write-only channel, and both the input translation and the output translation for a read-write channel. When two translations are given, they are the input and output translation, respectively. When only one translation is given for a read-write channel, it is the translation for both input and @@ -343,7 +340,7 @@ handler, the handler is deleted if \fIscript\fR returns an error so that it is not evaluated again. .PP Without an event handler, \fBchan gets\fR or \fBchan read\fR on a channel in -blocking mode may block until data becomes available, become during which the +blocking mode may block until data becomes available, during which the thread is unable to perform other work or respond to events on other channels. This could cause the application to appear to .QW "freeze up" @@ -386,23 +383,47 @@ while all buffered output is flushed in the background as soon as possible. .TP \fBchan gets \fIchannelName\fR ?\fIvarName\fR? . -Returns the next line from the channel, removing the trailing line feed, or if -\fIvarName\fR is given, assigns the line to that variable and returns the -number of characters read. -the line that was read, removing the trailing line feed, or returns the -empty string if there is no data to return and the end of the file has been -reached, or in non-blocking mode, if no complete line is currently available. -If \fIvarName\fR is given, assigns the line that was read to variable named -\fIvarName\fR and returns the number of characters that were read, or -1 if -there no data available and the end of the channel was reached or the channel -is in non-blocking mode. +Reads a line from the channel consisting of all characters up to the next +end-of-line sequence or until end of file is seen. The line feed character +corresponding to end-of-line sequence is not included as part of the line. +If the \fIvarName\fR argument is specified, the line is stored in the variable +of that name and the command returns the length of the line. If \fIvarName\fR +is not specified, the command returns the line itself as the result of the command. +.RS +.PP +If a complete line is not available and the channel is not at EOF, the command +will block in the case of a blocking channel. For non-blocking channels, the +command will return the empty string as the result in the case of \fIvarName\fR +not specified and -1 if it is. +.RE .RS .PP -If the end of the channel is reached the data read so far is returned or -assigned to \fIvarName\fR. When \fIvarName\fR is not given, \fBchan eof\fR may -indicate that the empty string means that the end of the data has been reached, -and \fBchan blocked\fR may indicate that that the empty string means there -isn't currently enough data do return the next line. +If a blocking channel is already at EOF, the command returns an empty string if +\fIvarName\fR is not specified. Note an empty string result can also be returned +when a blank line (no characters before the next end of line sequence). The two +cases can be distinguished by calling the \fBchan eof\fR command to check for +end of file. If \fIvarName\fR is specified, the command returns -1 on end of file. +There is no ambiguity in this case because blank lines result in 0 being returned. +.RE +.RS +.PP +If a non-blocking channel is already at EOF, the command returns an empty line +if \fIvarName\fR is not specified. This can be distinguished from an empty line +being returned by either a blank line being read or a full line not being available +through the use of the \fBchan eof\fR and \fBchan blocked\fR commands. If +\fBchan eof\fR returns true, the channel is at EOF. If \fBchan blocked\fR returns +true, a full line was not available. If both commands return false, an empty +line was read. If \fIvarName\fR was specified for a non-bocking channel at EOF, +the command returns -1. This can be distinguished from full line not being +available either by \fBchan eof\fR or \fBchan blocked\fR as above. Note that +when \fIvarName\fR is specified, there is no need to distinguish between eof +and blank lines as the latter will result in the command returning 0. +.PP +If the encoding profile \fBstrict\fR is in effect for the channel, the command +will raise an exception with the POSIX error code \fBEILSEQ\fR if any encoding +errors are encountered in the channel input data. The file pointer remains +unchanged and it is possible to introspect, and in some cases recover, by +changing the encoding in use. See \fBENCODING ERROR EXAMPLES\fR later. .RE .\" METHOD: names .TP @@ -509,8 +530,8 @@ given, the trailing line feed is not written. The default channel is \fBstdout\fR. .RS .PP -Each line feed in the output is translated according to the configuration of -\fB\-translation\fR. +Each line feed in the output is translated to the appropriate end of line +sequence as per the \fB\-translation\fR configuration setting of the channel. .PP Because Tcl internally buffers output, characters written to a channel may not immediately be available at the destination. Tcl normally delays output until @@ -518,17 +539,21 @@ the buffer is full or the channel is closed. \fBchan flush\fR forces output in the direction of the destination. .PP When the output for a channel in blocking mode fills up, \fBchan puts\fR blocks -until space in the buffer is available again, but for a channel in non-blocking -mode, it returns immediately and the data is written in the background as fast -possible, constrained by the speed at which as the destination accepts it. -Output to a channel in non-blocking mode only works properly when the -application enters the event loop, giving Tcl a chance to find out that the -destination is ready to accept more data. When a channel is in non-blocking -mode, Tcl's internal buffers can hold an arbitrary amount of data, possibly -consuming a large amount of memory. To avoid wasting memory, channels in -non-blocking mode should normally be handled using \fBchan event\fR, where the -application only invokes \fBchan puts\fR after being recently notified through -a file event handler that the channel is ready for more output data. +until space in the buffer is available again. On the other hand for a channel in +non-blocking mode, it returns immediately and the data is written in the +background as fast possible, constrained by the speed at which as the +destination accepts it. Output to a channel in non-blocking mode only works +properly when the application enters the event loop. When a channel is in +non-blocking mode, Tcl's internal buffers can hold an arbitrary amount of data, +possibly consuming a large amount of memory. To avoid wasting memory, channels +in non-blocking mode should normally be handled using \fBchan event\fR, where +the application only invokes \fBchan puts\fR after being notified through a file +event handler that the channel is ready for more output data. +.PP +The command will raise an error exception with POSIX error code \fBEILSEQ\fR if +the encoding profile \fBstrict\fR is in effect for the channel and the output +data cannot be encoded in the encoding configured for the channel. Data +may be partially written to the channel in this case. .RE .\" METHOD: read .TP @@ -541,7 +566,7 @@ Reads and returns the next \fInumChars\fR characters from the channel. If are read, or if the channel is in non-blocking mode, all currently-available characters are read. If there is an error on the channel, reading ceases and an error is returned. If \fInumChars\fR is not given, \fB\-nonewline\fR -may be given, causing any any trailing line feed to be trimmed. +may be given, causing any trailing line feed to be trimmed. .RS .PP If the channel is in non-blocking mode, fewer characters than requested may be @@ -560,6 +585,21 @@ handler since most serial ports are comparatively slow. It is entirely possible to get a \fBreadable\fR event for each individual character. In blocking mode, \fBchan read\fR blocks forever when reading to the end of the data if there is no \fBchan configure -eofchar\fR configured for the channel. +.PP +If the encoding profile \fBstrict\fR is in effect for the channel, the command +will raise an exception with the POSIX error code \fBEILSEQ\fR if any encoding +errors are encountered in the channel input data. If the channel is in blocking +mode, the error is thrown after advancing the file pointer to the beginning of +the invalid data. The successfully decoded leading portion of the data prior to +the error location is returned as the value of the \fB\-data\fR key of the error +option dictionary. If the channel is in non-blocking mode, the successfully +decoded portion of data is returned by the command without an error +exception being raised. A subsequent read will start at the invalid data +and immediately raise a \fBEILSEQ\fR POSIX error exception. Unlike the +blocking channel case, the \fB\-data\fR key is not present in the +error option dictionary. In the case of exception thrown due to encoding +errors, it is possible to introspect, and in some cases recover, by +changing the encoding in use. See \fBENCODING ERROR EXAMPLES\fR later. .RE .\" METHOD: seek .TP @@ -602,6 +642,13 @@ bytes, or to the current position in bytes if \fIlength\fR is omitted. .SH EXAMPLES .SS "SIMPLE CHANNEL OPERATION EXAMPLES" .PP +Instruct Tcl to always send output to \fBstdout\fR immediately, +whether or not it is to a terminal: +.PP +.CS +\fBfconfigure\fR stdout -buffering none +.CE +.PP In the following example a file is opened using the encoding CP1252, which is common on Windows, searches for a string, rewrites that part, and truncates the file two lines later. @@ -635,6 +682,67 @@ while {[\fBchan gets\fR $f line] >= 0} { \fBchan close\fR $f .CE .PP +This example illustrates flushing of a channel. The user is +prompted for some information. Because the standard input channel +is line buffered, it must be flushed for the user to see the prompt. +.PP +.CS +chan puts -nonewline "Please type your name: " +\fBchan flush\fR stdout +chan gets stdin name +chan puts "Hello there, $name!" +.CE +.PP +This example reads a file one line at a time and prints it out with +the current line number attached to the start of each line. +.PP +.CS +set chan [open "some.file.txt"] +set lineNumber 0 +while {[\fBchan gets\fR $chan line] >= 0} { + chan puts "[incr lineNumber]: $line" +} +chan close $chan +.CE +.PP +In this example illustrating event driven reads, +\fBGetData\fR will be called with the channel as an +argument whenever $chan becomes readable. The \fBread\fR call will +read whatever binary data is currently available without blocking. +Here the channel has the fileevent removed when an end of file +occurs to avoid being continually called (see above). Alternatively +the channel may be closed on this condition. +.PP +.CS +proc GetData {chan} { + set data [chan read $chan] + chan puts "[string length $data] $data" + if {[chan eof $chan]} { + chan event $chan readable {} + } +} + +chan configure $chan -blocking 0 -encoding binary +\fBchan event\fR $chan readable [list GetData $chan] +.CE +.PP +The next example is similar but uses \fBchan gets\fR to read +line-oriented data. +.PP +.CS +proc GetData {chan} { + if {[chan gets $chan line] >= 0} { + chan puts $line + } + if {[chan eof $chan]} { + chan close $chan + } +} + +chan configure $chan -blocking 0 -buffering line -translation crlf +\fBchan event\fR $chan readable [list GetData $chan] +.CE +.PP A network server that echoes its input line-by-line without preventing servicing of other connections at the same time: .PP @@ -671,6 +779,120 @@ proc echoLine {chan clientName} { socket -server connect 12345 vwait forever .CE +.PP +The following example reads a PPM-format image from a file +combining ASCII and binary content. +.PP +.CS +# Open the file and put it into Unix ASCII mode +set f [open teapot.ppm] +\fBchan configure\fR $f -encoding ascii -translation lf + +# Get the header +if {[chan gets $f] ne "P6"} { + error "not a raw\-bits PPM" +} + +# Read lines until we have got non-comment lines +# that supply us with three decimal values. +set words {} +while {[llength $words] < 3} { + chan gets $f line + if {[string match "#*" $line]} continue + lappend words {*}[join [scan $line %d%d%d]] +} + +# Those words supply the size of the image and its +# overall depth per channel. Assign to variables. +lassign $words xSize ySize depth + +# Now switch to binary mode to pull in the data, +# one byte per channel (red,green,blue) per pixel. +\fBchan configure\fR $f -translation binary +set numDataBytes [expr {3 * $xSize * $ySize}] +set data [chan read $f $numDataBytes] + +close $f +.CE + +.SS "ENCODING ERROR EXAMPLES" +.PP +The example below illustrates handling of an encoding error encountered +during channel input. First, creation of a test file containing +the invalid UTF-8 sequence (\fBA \\xC3 B\fR): +.PP +.CS +% set f [open test_A_195_B.txt wb]; chan puts -nonewline $f A\\xC3B; chan close $f +.CE +.PP +An attempt to read the file will result in an encoding error which is +then introspected by switching the channel to binary mode. Note in the +example that when the error is reported the file position remains +unchanged so that the \fBchan gets\fR during recovery returns the +full line. +.PP +.CS +% set f [open test_A_195_B.txt r] +file384b6a8 +% chan configure $f -encoding utf-8 -profile strict +% catch {chan gets $f} e d +1 +% set d +-code 1 -level 0 +-errorstack {INNER {invokeStk1 gets file384b6a8}} +-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} +-errorinfo {...} -errorline 1 +% chan tell $f +0 +% chan configure $f -encoding binary -profile strict +% chan gets $f +AÃB +.CE +.PP +The following example is similar to the above but demonstrates recovery after a +blocking read. The successfully decoded data "A" is returned in the error options +dictionary key \fB\-data\fR. The file position is advanced on the encoding error +position 1. The data at the error position is thus recovered by the next +\fBchan read\fR command. +.PP +.CS +% set f [open test_A_195_B.txt r] +file35a65a0 +% chan configure $f -encoding utf-8 -profile strict -blocking 1 +% catch {chan read $f} e d +1 +% set d +-data A -code 1 -level 0 +-errorstack {INNER {invokeStk1 read file35a65a0}} +-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} +-errorinfo {...} -errorline 1 +% chan tell $f +1 +% chan configure $f -encoding binary -profile strict +% chan read $f +ÃB +% chan close $f +.CE +.PP +Finally the same example, but this time with a non-blocking channel. +.PP +.CS +% set f [open test_A_195_B.txt r] +file35a65a0 +% chan configure $f -encoding utf-8 -profile strict -blocking 0 +% chan read $f +A +% chan tell $f +1 +% catch {chan read $f} e d +1 +% set d +-code 1 -level 0 +-errorstack {INNER {invokeStk1 read file384b228}} +-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} +-errorinfo {...} -errorline 1 +.CE + .SS "CHANNEL COPY EXAMPLES" .PP The first example transfers the contents of one channel exactly to @@ -760,7 +982,8 @@ close(n), eof(n), fblocked(n), fconfigure(n), fcopy(n), file(n), fileevent(n), flush(n), gets(n), open(n), puts(n), read(n), seek(n), socket(n), tell(n), refchan(n), transchan(n) .SH KEYWORDS -channel, input, output, events, offset +blocking, channel, end of file, events, input, non-blocking, +offset, output, readable, writable '\" Local Variables: '\" mode: nroff '\" End: diff --git a/doc/close.n b/doc/close.n index 2066583..900679e 100644 --- a/doc/close.n +++ b/doc/close.n @@ -15,98 +15,10 @@ close \- Close an open channel \fBclose \fIchannelId\fR ?\fBr\fR(\fBead\fR)|\fBw\fR(\fBrite\fR)? .BE .SH DESCRIPTION -.PP -Closes or half-closes the channel given by \fIchannelId\fR. \fBchan close\fR -is another name for this command. -.PP -\fIChannelId\fR must be an identifier for an open channel such as a -Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), -the return value from an invocation of \fBopen\fR or \fBsocket\fR, or -the result of a channel creation command provided by a Tcl extension. -.PP -The single-argument form is a simple -.QW "full-close" : -all buffered output is flushed to the channel's output device, -any buffered input is discarded, the underlying file or device is closed, -and \fIchannelId\fR becomes unavailable for use. -.PP -If the channel is blocking, the command does not return until all output -is flushed. -If the channel is nonblocking and there is unflushed output, the -channel remains open and the command -returns immediately; output will be flushed in the background and the -channel will be closed when all the flushing is complete. -.PP -If \fIchannelId\fR is a blocking channel for a command pipeline then -\fBclose\fR waits for the child processes to complete. -.PP -If the channel is shared between interpreters, then \fBclose\fR -makes \fIchannelId\fR unavailable in the invoking interpreter but has no -other effect until all of the sharing interpreters have closed the -channel. -When the last interpreter in which the channel is registered invokes -\fBclose\fR, the cleanup actions described above occur. See the -\fBinterp\fR command for a description of channel sharing. -.PP -Channels are automatically closed when an interpreter is destroyed and -when the process exits. -From 8.6 on (TIP#398), nonblocking channels are no longer switched to -blocking mode when exiting; this guarantees a timely exit even when the -peer or a communication channel is stalled. To ensure proper flushing of -stalled nonblocking channels on exit, one must now either (a) actively -switch them back to blocking or (b) use the environment variable -\fBTCL_FLUSH_NONBLOCKING_ON_EXIT\fR, which when set and not equal to -.QW \fB0\fR -restores the previous behavior. -.PP -The command returns an empty string, and may generate an error if -an error occurs while flushing output. If a command in a command -pipeline created with \fBopen\fR returns an error (either by returning a -non-zero exit code or writing to its standard error file descriptor), -\fBclose\fR generates an error (similar to the \fBexec\fR command.) -.PP -The two-argument form is a -.QW "half-close" : -given a bidirectional channel like a -socket or command pipeline and a (possibly abbreviated) direction, it closes -only the sub-stream going in that direction. This means a shutdown() on a -socket, and a close() of one end of a pipe for a command pipeline. Then, the -Tcl-level channel data structure is either kept or freed depending on whether -the other direction is still open. -.PP -A single-argument close on an already half-closed bidirectional channel is -defined to just -.QW "finish the job" . -A half-close on an already closed half, or on a wrong-sided unidirectional -channel, raises an error. -.PP -In the case of a command pipeline, the child-reaping duty falls upon the -shoulders of the last close or half-close, which is thus allowed to report an -abnormal exit error. -.PP -Currently only sockets and command pipelines support half-close. A future -extension will allow reflected and stacked channels to do so. -.SH EXAMPLE -.PP -This illustrates how you can use Tcl to ensure that files get closed -even when errors happen by combining \fBcatch\fR, \fBclose\fR and -\fBreturn\fR: -.PP -.CS -proc withOpenFile {filename channelVar script} { - upvar 1 $channelVar chan - set chan [open $filename] - catch { - uplevel 1 $script - } result options - \fBclose\fR $chan - return -options $options $result -} -.CE +The \fBclose\fR command has been superceded by the \fBchan close\fR +command and supports the same syntax and options. .SH "SEE ALSO" -chan(n), file(n), open(n), socket(n), eof(n), Tcl_StandardChannels(3) -.SH KEYWORDS -blocking, channel, close, nonblocking, half-close +chan(n) '\" Local Variables: '\" mode: nroff '\" fill-column: 78 diff --git a/doc/eof.n b/doc/eof.n index 0dcf34a..c0d09b4 100644 --- a/doc/eof.n +++ b/doc/eof.n @@ -16,49 +16,10 @@ eof \- Check for end of file condition on channel .BE .SH DESCRIPTION .PP -Returns 1 if an end of file condition occurred during the most -recent input operation on \fIchannelId\fR (such as \fBgets\fR), -0 otherwise. -.PP -\fIChannelId\fR must be an identifier for an open channel such as a -Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), -the return value from an invocation of \fBopen\fR or \fBsocket\fR, or -the result of a channel creation command provided by a Tcl extension. -.SH EXAMPLES -.PP -Read and print out the contents of a file line-by-line: -.PP -.CS -set f [open somefile.txt] -while {1} { - set line [gets $f] - if {[\fBeof\fR $f]} { - close $f - break - } - puts "Read line: $line" -} -.CE -.PP -Read and print out the contents of a file by fixed-size records: -.PP -.CS -set f [open somefile.dat] -fconfigure $f -translation binary -set recordSize 40 -while {1} { - set record [read $f $recordSize] - if {[\fBeof\fR $f]} { - close $f - break - } - puts "Read record: $record" -} -.CE +The \fBeof\fR command has been superceded by the \fBchan eof\fR +command. It supports the same syntax and options as the latter. .SH "SEE ALSO" -file(n), open(n), close(n), fblocked(n), Tcl_StandardChannels(3) -.SH KEYWORDS -channel, end of file +chan(n) '\" Local Variables: '\" mode: nroff '\" fill-column: 78 diff --git a/doc/fblocked.n b/doc/fblocked.n index 44dfcd5..625a79a 100644 --- a/doc/fblocked.n +++ b/doc/fblocked.n @@ -14,56 +14,10 @@ fblocked \- Test whether the last input operation exhausted all available input .BE .SH DESCRIPTION .PP -The \fBfblocked\fR command returns 1 if the most recent input operation -on \fIchannelId\fR returned less information than requested because all -available input was exhausted. -For example, if \fBgets\fR is invoked when there are only three -characters available for input and no end-of-line sequence, \fBgets\fR -returns an empty string and a subsequent call to \fBfblocked\fR will -return 1. -.PP -\fIChannelId\fR must be an identifier for an open channel such as a -Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), -the return value from an invocation of \fBopen\fR or \fBsocket\fR, or -the result of a channel creation command provided by a Tcl extension. -.SH EXAMPLE -The \fBfblocked\fR command is particularly useful when writing network -servers, as it allows you to write your code in a line-by-line style -without preventing the servicing of other connections. This can be -seen in this simple echo-service: -.PP -.CS -# This is called whenever a new client connects to the server -proc connect {chan host port} { - set clientName [format <%s:%d> $host $port] - puts "connection from $clientName" - fconfigure $chan -blocking 0 -buffering line - fileevent $chan readable [list echoLine $chan $clientName] -} - -# This is called whenever either at least one byte of input -# data is available, or the channel was closed by the client. -proc echoLine {chan clientName} { - gets $chan line - if {[eof $chan]} { - puts "finishing connection from $clientName" - close $chan - } elseif {![\fBfblocked\fR $chan]} { - # Didn't block waiting for end-of-line - puts "$clientName - $line" - puts $chan $line - } -} - -# Create the server socket and enter the event-loop to wait -# for incoming connections... -socket -server connect 12345 -vwait forever -.CE +The \fBfblocked\fR command has been superceded by the \fBchan blocked\fR +command. It supports the same syntax and options as the latter. .SH "SEE ALSO" -gets(n), open(n), read(n), socket(n), Tcl_StandardChannels(3) -.SH KEYWORDS -blocking, nonblocking +chan(n) '\" Local Variables: '\" mode: nroff '\" fill-column: 78 diff --git a/doc/fconfigure.n b/doc/fconfigure.n index 468cd62..e7978d0 100644 --- a/doc/fconfigure.n +++ b/doc/fconfigure.n @@ -19,269 +19,10 @@ fconfigure \- Set and get options on a channel .BE .SH DESCRIPTION .PP -The \fBfconfigure\fR command sets and retrieves options for channels. -.PP -\fIChannelId\fR identifies the channel for which to set or query an -option and must refer to an open channel such as a Tcl standard -channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), the return -value from an invocation of \fBopen\fR or \fBsocket\fR, or the result -of a channel creation command provided by a Tcl extension. -.PP -If no \fIname\fR or \fIvalue\fR arguments are supplied, the command -returns a list containing alternating option names and values for the channel. -If \fIname\fR is supplied but no \fIvalue\fR then the command returns -the current value of the given option. -If one or more pairs of \fIname\fR and \fIvalue\fR are supplied, the -command sets each of the named options to the corresponding \fIvalue\fR; -in this case the return value is an empty string. -.PP -The options described below are supported for all channels. In addition, -each channel type may add options that only it supports. See the manual -entry for the command that creates each type of channels for the options -that that specific type of channel supports. For example, see the manual -entry for the \fBsocket\fR command for additional options for sockets, and -the \fBopen\fR command for additional options for serial devices. -.\" OPTION: -blocking -.TP -\fB\-blocking\fI boolean\fR -. -The \fB\-blocking\fR option determines whether I/O operations on the -channel can cause the process to block indefinitely. -The value of the option must be a proper boolean value. -Channels are normally in blocking mode; if a channel is placed into -nonblocking mode it will affect the operation of the \fBgets\fR, -\fBread\fR, \fBputs\fR, \fBflush\fR, and \fBclose\fR commands by -allowing them to operate asynchronously; -see the documentation for those commands for details. -For nonblocking mode to work correctly, the application must be -using the Tcl event loop (e.g. by calling \fBTcl_DoOneEvent\fR or -invoking the \fBvwait\fR command). -.\" OPTION: -buffering -.TP -\fB\-buffering\fI newValue\fR -. -If \fInewValue\fR is \fBfull\fR then the I/O system will buffer output -until its internal buffer is full or until the \fBflush\fR command is -invoked. If \fInewValue\fR is \fBline\fR, then the I/O system will -automatically flush output for the channel whenever a newline character -is output. If \fInewValue\fR is \fBnone\fR, the I/O system will flush -automatically after every output operation. The default is for -\fB\-buffering\fR to be set to \fBfull\fR except for channels that -connect to terminal-like devices; for these channels the initial setting -is \fBline\fR. Additionally, \fBstdin\fR and \fBstdout\fR are -initially set to \fBline\fR, and \fBstderr\fR is set to \fBnone\fR. -.\" OPTION: -buffersize -.TP -\fB\-buffersize\fI newSize\fR -. -\fINewvalue\fR must be an integer; its value is used to set the size of -buffers, in bytes, subsequently allocated for this channel to store input -or output. \fINewvalue\fR must be between one and one million, allowing -buffers of one to one million bytes in size. -.\" OPTION: -encoding -.TP -\fB\-encoding\fI name\fR -. -This option is used to specify the encoding of the channel, so that the data -can be converted to and from Unicode for use in Tcl. For instance, in -order for Tcl to read characters from a Japanese file in \fBshiftjis\fR -and properly process and display the contents, the encoding would be set -to \fBshiftjis\fR. Thereafter, when reading from the channel, the bytes in -the Japanese file would be converted to Unicode as they are read. -Writing is also supported \- as Tcl strings are written to the channel they -will automatically be converted to the specified encoding on output. -.RS -.PP -If a file contains pure binary data (for instance, a JPEG image), the -encoding for the channel should be configured to be \fBbinary\fR. Tcl -will then assign no interpretation to the data in the file and simply read or -write raw bytes. The Tcl \fBbinary\fR command can be used to manipulate this -byte-oriented data. It is usually better to set the -\fB\-translation\fR option to \fBbinary\fR when you want to transfer -binary data, as this turns off the other automatic interpretations of -the bytes in the stream as well. -.PP -The default encoding for newly opened channels is the same platform- and -locale-dependent system encoding used for interfacing with the operating -system, as returned by \fBencoding system\fR. -.RE -.\" OPTION: -eofchar -.TP -\fB\-eofchar\fI char\fR -. -This option supports DOS file systems that use Control-z (\ex1A) as an -end of file marker. If \fIchar\fR is not an empty string, then this -character signals end-of-file when it is encountered during input. -If \fIchar\fR is the empty string, then there is no special end of file -character marker. The default value for \fB\-eofchar\fR is the empty -string. -The acceptable range for \fB\-eofchar\fR values is \ex01 - \ex7F; -attempting to set \fB\-eofchar\fR to a value outside of this range will -generate an error. -.VS "TCL8.7 TIP656" -.\" OPTION: -profile -.TP -\fB\-profile\fI profile\fR -. -Specifies the encoding profile to be used on the channel. The encoding -transforms in use for the channel's input and output will then be subject to the -rules of that profile. Any failures will result in a channel error. See -\fBPROFILES\fR in the \fBencoding(n)\fR documentation for details about encoding -profiles. -.VE "TCL8.7 TIP656" -.\" OPTION: -translation -.TP -\fB\-translation\fI mode\fR -.TP -\fB\-translation\fR \fB{\fIinMode outMode\fB}\fR -. -In Tcl scripts the end of a line is always represented using a single -newline character (\en). However, in actual files and devices the end of -a line may be represented differently on different platforms, or even for -different devices on the same platform. For example, under UNIX newlines -are used in files, whereas carriage-return-linefeed sequences are -normally used in network connections. On input (i.e., with \fBgets\fR -and \fBread\fR) the Tcl I/O system automatically translates the external -end-of-line representation into newline characters. Upon output (i.e., -with \fBputs\fR), the I/O system translates newlines to the external -end-of-line representation. The default translation mode, \fBauto\fR, -handles all the common cases automatically, but the \fB\-translation\fR -option provides explicit control over the end of line translations. -.RS -.PP -The value associated with \fB\-translation\fR is a single item for -read-only and write-only channels. The value is a two-element list for -read-write channels; the read translation mode is the first element of -the list, and the write translation mode is the second element. As a -convenience, when setting the translation mode for a read-write channel -you can specify a single value that will apply to both reading and -writing. When querying the translation mode of a read-write channel, a -two-element list will always be returned. The following values are -currently supported: -.IP \fBauto\fR -As the input translation mode, \fBauto\fR treats any of newline -(\fBlf\fR), carriage return (\fBcr\fR), or carriage return followed by a -newline (\fBcrlf\fR) as the end of line representation. The end of line -representation can even change from line-to-line, and all cases are -translated to a newline. As the output translation mode, \fBauto\fR -chooses a platform specific representation; for sockets on all platforms -Tcl chooses \fBcrlf\fR, for all Unix flavors, it chooses \fBlf\fR, and -for the various flavors of Windows it chooses \fBcrlf\fR. The default -setting for \fB\-translation\fR is \fBauto\fR for both input and output. -.IP \fBbinary\fR -No end-of-line translations are performed. This is nearly identical to -\fBlf\fR mode, except that in addition \fBbinary\fR mode also sets the -end-of-file character to the empty string (which disables it) and sets the -encoding to \fBbinary\fR (which disables encoding filtering). See the -description of \fB\-eofchar\fR and \fB\-encoding\fR for more information. -.RS -.PP -Internally, i.e. when it comes to the actual behaviour of the -translator this value \fBis\fR identical to \fBlf\fR and is therefore -reported as such when queried. Even if \fBbinary\fR was used to set -the translation. -.RE -.IP \fBcr\fR -The end of a line in the underlying file or device is represented by a -single carriage return character. As the input translation mode, -\fBcr\fR mode converts carriage returns to newline characters. As the -output translation mode, \fBcr\fR mode translates newline characters to -carriage returns. -.IP \fBcrlf\fR -The end of a line in the underlying file or device is represented by a -carriage return character followed by a linefeed character. As the input -translation mode, \fBcrlf\fR mode converts carriage-return-linefeed -sequences to newline characters. As the output translation mode, -\fBcrlf\fR mode translates newline characters to carriage-return-linefeed -sequences. This mode is typically used on Windows platforms and for -network connections. -.IP \fBlf\fR -The end of a line in the underlying file or device is represented by a -single newline (linefeed) character. In this mode no translations occur -during either input or output. This mode is typically used on UNIX -platforms. -.RE -.PP -.SH "STANDARD CHANNELS" -.PP -The Tcl standard channels (\fBstdin\fR, \fBstdout\fR, and \fBstderr\fR) -can be configured through this command like every other channel opened -by the Tcl library. Beyond the standard options described above they -will also support any special option according to their current type. -If, for example, a Tcl application is started by the \fBinet\fR -super-server common on Unix system its Tcl standard channels will be -sockets and thus support the socket options. -.SH EXAMPLES -.PP -Instruct Tcl to always send output to \fBstdout\fR immediately, -whether or not it is to a terminal: -.PP -.CS -\fBfconfigure\fR stdout -buffering none -.CE -.PP -Open a socket and read lines from it without ever blocking the -processing of other events: -.PP -.CS -set s [socket some.where.com 12345] -\fBfconfigure\fR $s -blocking 0 -fileevent $s readable "readMe $s" -proc readMe chan { - if {[gets $chan line] < 0} { - if {[eof $chan]} { - close $chan - return - } - # Could not read a complete line this time; Tcl's - # internal buffering will hold the partial line for us - # until some more data is available over the socket. - } else { - puts stdout $line - } -} -.CE -.PP -Read a PPM-format image from a file: -.PP -.CS -# Open the file and put it into Unix ASCII mode -set f [open teapot.ppm] -\fBfconfigure\fR $f -encoding ascii -translation lf - -# Get the header -if {[gets $f] ne "P6"} { - error "not a raw\-bits PPM" -} - -# Read lines until we have got non-comment lines -# that supply us with three decimal values. -set words {} -while {[llength $words] < 3} { - gets $f line - if {[string match "#*" $line]} continue - lappend words {*}[join [scan $line %d%d%d]] -} - -# Those words supply the size of the image and its -# overall depth per channel. Assign to variables. -lassign $words xSize ySize depth - -# Now switch to binary mode to pull in the data, -# one byte per channel (red,green,blue) per pixel. -\fBfconfigure\fR $f -translation binary -set numDataBytes [expr {3 * $xSize * $ySize}] -set data [read $f $numDataBytes] - -close $f -.CE +The \fBfconfigure\fR command has been superceded by the \fBchan configure\fR +command. It supports the same syntax and options as the latter. .SH "SEE ALSO" -close(n), encoding(n), flush(n), gets(n), open(n), puts(n), read(n), socket(n), -Tcl_StandardChannels(3) -.SH KEYWORDS -blocking, buffering, carriage return, end of line, encoding, flushing, linemode, -newline, nonblocking, platform, profile, translation, encoding, filter, -byte array, binary +chan(n) '\" Local Variables: '\" mode: nroff '\" End: diff --git a/doc/fileevent.n b/doc/fileevent.n index c302b39..7be3e2e 100644 --- a/doc/fileevent.n +++ b/doc/fileevent.n @@ -19,140 +19,10 @@ fileevent \- Execute a script when a channel becomes readable or writable .BE .SH DESCRIPTION .PP -This command is used to create \fIfile event handlers\fR. A file event -handler is a binding between a channel and a script, such that the script -is evaluated whenever the channel becomes readable or writable. File event -handlers are most commonly used to allow data to be received from another -process on an event-driven basis, so that the receiver can continue to -interact with the user while waiting for the data to arrive. If an -application invokes \fBgets\fR or \fBread\fR on a blocking channel when -there is no input data available, the process will block; until the input -data arrives, it will not be able to service other events, so it will -appear to the user to -.QW "freeze up" . -With \fBfileevent\fR, the process can -tell when data is present and only invoke \fBgets\fR or \fBread\fR when -they will not block. -.PP -The \fIchannelId\fR argument to \fBfileevent\fR refers to an open -channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR, -or \fBstderr\fR), the return value from an invocation of \fBopen\fR -or \fBsocket\fR, or the result of a channel creation command provided -by a Tcl extension. -.PP -If the \fIscript\fR argument is specified, then \fBfileevent\fR -creates a new event handler: \fIscript\fR will be evaluated -whenever the channel becomes readable or writable (depending on the -second argument to \fBfileevent\fR). -In this case \fBfileevent\fR returns an empty string. -The \fBreadable\fR and \fBwritable\fR event handlers for a file -are independent, and may be created and deleted separately. -However, there may be at most one \fBreadable\fR and one \fBwritable\fR -handler for a file at a given time in a given interpreter. -If \fBfileevent\fR is called when the specified handler already -exists in the invoking interpreter, the new script replaces the old one. -.PP -If the \fIscript\fR argument is not specified, \fBfileevent\fR -returns the current script for \fIchannelId\fR, or an empty string -if there is none. -If the \fIscript\fR argument is specified as an empty string -then the event handler is deleted, so that no script will be invoked. -A file event handler is also deleted automatically whenever -its channel is closed or its interpreter is deleted. -.PP -A channel is considered to be readable if there is unread data -available on the underlying device. -A channel is also considered to be readable if there is unread -data in an input buffer, except in the special case where the -most recent attempt to read from the channel was a \fBgets\fR -call that could not find a complete line in the input buffer. -This feature allows a file to be read a line at a time in nonblocking mode -using events. -A channel is also considered to be readable if an end of file or -error condition is present on the underlying file or device. -It is important for \fIscript\fR to check for these conditions -and handle them appropriately; for example, if there is no special -check for end of file, an infinite loop may occur where \fIscript\fR -reads no data, returns, and is immediately invoked again. -.PP -A channel is considered to be writable if at least one byte of data -can be written to the underlying file or device without blocking, -or if an error condition is present on the underlying file or device. -.PP -Event-driven I/O works best for channels that have been placed into -nonblocking mode with the \fBfconfigure\fR command. In blocking mode, -a \fBputs\fR command may block if you give it more data than the -underlying file or device can accept, and a \fBgets\fR or \fBread\fR -command will block if you attempt to read more data than is ready; a -readable underlying file or device may not even guarantee that a -blocking [read 1] will succeed (counter-examples being multi-byte -encodings, compression or encryption transforms ). In all such cases, -no events will be processed while the commands block. -.PP -In nonblocking mode \fBputs\fR, \fBread\fR, and \fBgets\fR never block. -See the documentation for the individual commands for information -on how they handle blocking and nonblocking channels. -.PP -Testing for the end of file condition should be done after any attempts -read the channel data. The eof flag is set once an attempt to read the -end of data has occurred and testing before this read will require an -additional event to be fired. -.PP -The script for a file event is executed at global level (outside the -context of any Tcl procedure) in the interpreter in which the -\fBfileevent\fR command was invoked. -If an error occurs while executing the script then the -command registered with \fBinterp bgerror\fR is used to report the error. -In addition, the file event handler is deleted if it ever returns -an error; this is done in order to prevent infinite loops due to -buggy handlers. -.SH EXAMPLE -.PP -In this setup \fBGetData\fR will be called with the channel as an -argument whenever $chan becomes readable. The \fBread\fR call will -read whatever binary data is currently available without blocking. -Here the channel has the fileevent removed when an end of file -occurs to avoid being continually called (see above). Alternatively -the channel may be closed on this condition. -.PP -.CS -proc GetData {chan} { - set data [read $chan] - puts "[string length $data] $data" - if {[eof $chan]} { - fileevent $chan readable {} - } -} - -fconfigure $chan -blocking 0 -encoding binary -\fBfileevent\fR $chan readable [list GetData $chan] -.CE -.PP -The next example demonstrates use of \fBgets\fR to read line-oriented -data. -.PP -.CS -proc GetData {chan} { - if {[gets $chan line] >= 0} { - puts $line - } - if {[eof $chan]} { - close $chan - } -} - -fconfigure $chan -blocking 0 -buffering line -translation crlf -\fBfileevent\fR $chan readable [list GetData $chan] -.CE -.SH CREDITS -.PP -\fBfileevent\fR is based on the \fBaddinput\fR command created -by Mark Diekhans. +The \fBfileevent\fR command has been superceded by the \fBchan event\fR +command and supports the same syntax and options. .SH "SEE ALSO" -fconfigure(n), gets(n), interp(n), puts(n), read(n), Tcl_StandardChannels(3) -.SH KEYWORDS -asynchronous I/O, blocking, channel, event handler, nonblocking, readable, -script, writable. +chan(n) '\" Local Variables: '\" mode: nroff '\" fill-column: 78 diff --git a/doc/flush.n b/doc/flush.n index 1d84383..57c1c67 100644 --- a/doc/flush.n +++ b/doc/flush.n @@ -16,33 +16,10 @@ flush \- Flush buffered output for a channel .BE .SH DESCRIPTION .PP -Flushes any output that has been buffered for \fIchannelId\fR. -.PP -\fIChannelId\fR must be an identifier for an open channel such as a -Tcl standard channel (\fBstdout\fR or \fBstderr\fR), the return -value from an invocation of \fBopen\fR or \fBsocket\fR, or the result -of a channel creation command provided by a Tcl extension. The -channel must have been opened for writing. -.PP -If the channel is in blocking mode the command does not return until all the -buffered output has been flushed to the channel. If the channel is in -nonblocking mode, the command may return before all buffered output has been -flushed; the remainder will be flushed in the background as fast as the -underlying file or device is able to absorb it. -.SH EXAMPLE -.PP -Prompt for the user to type some information in on the console: -.PP -.CS -puts -nonewline "Please type your name: " -\fBflush\fR stdout -gets stdin name -puts "Hello there, $name!" -.CE +The \fBflush\fR command has been superceded by the \fBchan flush\fR +command and supports the same syntax and options. .SH "SEE ALSO" -file(n), open(n), socket(n), Tcl_StandardChannels(3) -.SH KEYWORDS -blocking, buffer, channel, flush, nonblocking, output +chan(n) '\" Local Variables: '\" mode: nroff '\" fill-column: 78 diff --git a/doc/gets.n b/doc/gets.n index 33d8cf6..99c5f72 100644 --- a/doc/gets.n +++ b/doc/gets.n @@ -16,89 +16,10 @@ gets \- Read a line from a channel .BE .SH DESCRIPTION .PP -This command reads the next line from \fIchannelId\fR, returns everything -in the line up to (but not including) the end-of-line character(s), and -discards the end-of-line character(s). -.PP -\fIChannelId\fR must be an identifier for an open channel such as the -Tcl standard input channel (\fBstdin\fR), the return value from an -invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel -creation command provided by a Tcl extension. The channel must have -been opened for input. -.PP -If \fIvarName\fR is omitted the line is returned as the result of the -command. -If \fIvarName\fR is specified then the line is placed in the variable by -that name and the return value is a count of the number of characters -returned. -.PP -If end of file occurs while scanning for an end of -line, the command returns whatever input is available up to the end of file. -If \fIchannelId\fR is in non-blocking mode and there is not a full -line of input available, the command returns an empty string and -does not consume any input. -If \fIvarName\fR is specified and an empty string is returned in -\fIvarName\fR because of end-of-file or because of insufficient -data in non-blocking mode, then the return count is -1. -Note that if \fIvarName\fR is not specified then the end-of-file -and no-full-line-available cases can -produce the same results as if there were an input line consisting -only of the end-of-line character(s). -The \fBeof\fR and \fBfblocked\fR commands can be used to distinguish -these three cases. -.SH "ENCODING ERRORS" -.PP -Encoding errors may exist, if the encoding profile \fBstrict\fR is used. -Encoding errors are special, as an eventual introspection or recovery is -possible by changing to an encoding which accepts the data. -An encoding error is reported by the POSIX error code \fBEILSEQ\fR. -The file pointer is unchanged in the error case. -.PP -Here is an example with an encoding error in UTF-8 encoding, which is then -introspected by a switch to the binary encoding. The test file contains a not -continued multi-byte sequence at position 1 (\fBA \\xC3 B\fR): -.PP -File creation for example -.CS -% set f [open test_A_195_B.txt wb]; puts -nonewline $f A\\xC3B; close $f -.CE -Encoding error example -.CS -% set f [open test_A_195_B.txt r] -file384b6a8 -% fconfigure $f -encoding utf-8 -profile strict -% catch {gets $f} e d -1 -% set d --code 1 -level 0 --errorstack {INNER {invokeStk1 gets file384b6a8}} --errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} --errorinfo {...} -errorline 1 -% tell $f -0 -% fconfigure $f -encoding binary -profile strict -% gets $f -AÃB -.CE -Compared to \fBread\fR, any already decoded data is not consumed. -The file position is still at 0 and the recovery \fBgets\fR returns also the -already well decoded leading data. -.SH "EXAMPLE" -This example reads a file one line at a time and prints it out with -the current line number attached to the start of each line. -.PP -.CS -set chan [open "some.file.txt"] -set lineNumber 0 -while {[\fBgets\fR $chan line] >= 0} { - puts "[incr lineNumber]: $line" -} -close $chan -.CE +The \fBgets\fR command has been superceded by the \fBchan gets\fR +command and supports the same syntax and options. .SH "SEE ALSO" -file(n), eof(n), fblocked(n), Tcl_StandardChannels(3) -.SH KEYWORDS -blocking, channel, end of file, end of line, line, non-blocking, read +chan(n) '\" Local Variables: '\" mode: nroff '\" fill-column: 78 diff --git a/doc/puts.n b/doc/puts.n index 5ce56b7..f3eb68e 100644 --- a/doc/puts.n +++ b/doc/puts.n @@ -16,89 +16,10 @@ puts \- Write to a channel .BE .SH DESCRIPTION .PP -Writes the characters given by \fIstring\fR to the channel given -by \fIchannelId\fR. -.PP -\fIChannelId\fR must be an identifier for an open channel such as a -Tcl standard channel (\fBstdout\fR or \fBstderr\fR), the return -value from an invocation of \fBopen\fR or \fBsocket\fR, or the result -of a channel creation command provided by a Tcl extension. The channel -must have been opened for output. -.PP -If no \fIchannelId\fR is specified then it defaults to -\fBstdout\fR. \fBPuts\fR normally outputs a newline character after -\fIstring\fR, but this feature may be suppressed by specifying the -\fB\-nonewline\fR switch. -.PP -Newline characters in the output are translated by \fBputs\fR to -platform-specific end-of-line sequences according to the current -value of the \fB\-translation\fR option for the channel (for example, -on PCs newlines are normally replaced with carriage-return-linefeed -sequences. -See the \fBfconfigure\fR manual entry for a discussion on ways in -which \fBfconfigure\fR will alter output. -.PP -Tcl buffers output internally, so characters written with \fBputs\fR -may not appear immediately on the output file or device; Tcl will -normally delay output until the buffer is full or the channel is -closed. -You can force output to appear immediately with the \fBflush\fR -command. -.PP -When the output buffer fills up, the \fBputs\fR command will normally -block until all the buffered data has been accepted for output by the -operating system. -If \fIchannelId\fR is in nonblocking mode then the \fBputs\fR command -will not block even if the operating system cannot accept the data. -Instead, Tcl continues to buffer the data and writes it in the -background as fast as the underlying file or device can accept it. -The application must use the Tcl event loop for nonblocking output -to work; otherwise Tcl never finds out that the file or device is -ready for more output data. -It is possible for an arbitrarily large amount of data to be -buffered for a channel in nonblocking mode, which could consume a -large amount of memory. -To avoid wasting memory, nonblocking I/O should normally -be used in an event-driven fashion with the \fBfileevent\fR command -(do not invoke \fBputs\fR unless you have recently been notified -via a file event that the channel is ready for more output data). -.SH "ENCODING ERRORS" -.PP -Encoding errors may exist, if the encoding profile \fBstrict\fR is used. -\fBputs\fR writes out data until an encoding error occurs and fails with -POSIX error code \fBEILSEQ\fR. -.SH EXAMPLES -.PP -Write a short message to the console (or wherever \fBstdout\fR is -directed): -.PP -.CS -\fBputs\fR "Hello, World!" -.CE -.PP -Print a message in several parts: -.PP -.CS -\fBputs\fR -nonewline "Hello, " -\fBputs\fR "World!" -.CE -.PP -Print a message to the standard error channel: -.PP -.CS -\fBputs\fR stderr "Hello, World!" -.CE -.PP -Append a log message to a file: -.PP -.CS -set chan [open my.log a] -set timestamp [clock format [clock seconds]] -\fBputs\fR $chan "$timestamp - Hello, World!" -close $chan -.CE +The \fBputs\fR command has been superceded by the \fBchan puts\fR +command and supports the same syntax and options. .SH "SEE ALSO" -file(n), fileevent(n), Tcl_StandardChannels(3) +chan(n) .SH KEYWORDS channel, newline, output, write '\" Local Variables: diff --git a/doc/read.n b/doc/read.n index a19e2a2..c797072 100644 --- a/doc/read.n +++ b/doc/read.n @@ -18,146 +18,10 @@ read \- Read from a channel .BE .SH DESCRIPTION .PP -In the first form, the \fBread\fR command reads all of the data from -\fIchannelId\fR up to the end of the file. If the \fB\-nonewline\fR -switch is specified then the last character of the file is discarded -if it is a newline. In the second form, the extra argument specifies -how many characters to read. Exactly that many characters will be -read and returned, unless there are fewer than \fInumChars\fR left in -the file; in this case all the remaining characters are returned. If -the channel is configured to use a multi-byte encoding, then the -number of characters read may not be the same as the number of bytes -read. -.PP -\fIChannelId\fR must be an identifier for an open channel such as the -Tcl standard input channel (\fBstdin\fR), the return value from an -invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel -creation command provided by a Tcl extension. The channel must have -been opened for input. -.PP -If \fIchannelId\fR is in nonblocking mode, the command may not read as -many characters as requested: once all available input has been read, -the command will return the data that is available rather than -blocking for more input. If the channel is configured to use a -multi-byte encoding, then there may actually be some bytes remaining -in the internal buffers that do not form a complete character. These -bytes will not be returned until a complete character is available or -end-of-file is reached. The \fB\-nonewline\fR switch is ignored if -the command returns before reaching the end of the file. -.PP -\fBRead\fR translates end-of-line sequences in the input into -newline characters according to the \fB\-translation\fR option -for the channel. -See the \fBfconfigure\fR manual entry for a discussion on ways in -which \fBfconfigure\fR will alter input. -.SH "ENCODING ERRORS" -.PP -Encoding errors may exist, if the encoding profile \fBstrict\fR is used. -Encoding errors are special, as an eventual introspection or recovery is -possible by changing to an encoding (or encoding profile), which accepts -the data. -An encoding error is reported by the POSIX error code \fBEILSEQ\fR. -.PP -In blocking mode, the error is directly thrown, even, if there is a -leading decodable data portion. -The file pointer is advanced just before the encoding error. -An eventual well decoded data chunk before the encoding error is returned -in the error option dictionary key \fB\-data\fR. -The value of the key contains the empty string, if the error arises at the -first data position. -.PP -In non blocking mode, first, any data without encoding error is returned -(without error state). -In the next call, no data is returned and the \fBEILSEQ\fR error state is set. -The key \fB\-data\fR is not present. -.PP -Here is an example with an encoding error in UTF-8 encoding, which is then -introspected by a switch to the binary encoding. The test file contains a not -continued multi-byte sequence at position 1 (\fBA \\xC3 B\fR): -.PP -File creation for examples -. -.CS -% set f [open test_A_195_B.txt wb]; puts -nonewline $f A\\xC3B; close $f -.CE -Blocking example -. -.CS -% set f [open test_A_195_B.txt r] -file35a65a0 -% fconfigure $f -encoding utf-8 -profile strict -blocking 1 -% catch {read $f} e d -1 -% set d --data A -code 1 -level 0 --errorstack {INNER {invokeStk1 read file35a65a0}} --errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} --errorinfo {...} -errorline 1 -% tell $f -1 -% fconfigure $f -encoding binary -profile strict -% read $f -ÃB -% close $f -.CE -The already decoded data "A" is returned in the error options dictionary key -\fB\-data\fR. -The file position is advanced on the encoding error position 1. -The data at the error position is thus recovered by the next \fBread\fR command. -.PP -Non blocking example -. -.CS -% set f [open test_A_195_B.txt r] -file35a65a0 -% fconfigure $f -encoding utf-8 -profile strict -blocking 0 -% read $f -A -% tell $f -1 -% catch {read $f} e d -1 -% set d --code 1 -level 0 --errorstack {INNER {invokeStk1 read file384b228}} --errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} --errorinfo {...} -errorline 1 -.CE -.SH "USE WITH SERIAL PORTS" -'\" Note: this advice actually applies to many versions of Tcl -.PP -For most applications a channel connected to a serial port should be -configured to be nonblocking: \fBfconfigure\fI channelId \fB\-blocking -\fI0\fR. Then \fBread\fR behaves much like described above. Care -must be taken when using \fBread\fR on blocking serial ports: -.TP -\fBread \fIchannelId numChars\fR -. -In this form \fBread\fR blocks until \fInumChars\fR have been received -from the serial port. -.TP -\fBread \fIchannelId\fR -. -In this form \fBread\fR blocks until the reception of the end-of-file -character, see \fBfconfigure\fR \fB\-eofchar\fR. If there no end-of-file -character has been configured for the channel, then \fBread\fR will -block forever. -.SH "EXAMPLE" -.PP -This example code reads a file all at once, and splits it into a list, -with each line in the file corresponding to an element in the list: -.PP -.CS -set fl [open /proc/meminfo] -set data [\fBread\fR $fl] -close $fl -set lines [split $data \en] -.CE +The \fBread\fR command has been superceded by the \fBchan read\fR +command and supports the same syntax and options. .SH "SEE ALSO" -file(n), eof(n), fblocked(n), fconfigure(n), Tcl_StandardChannels(3) -.SH KEYWORDS -blocking, channel, end of line, end of file, nonblocking, read, translation, -encoding +chan(n) '\"Local Variables: '\"mode: nroff '\"End: -- cgit v0.12 From 805c237f9558eebd6f14aa789b796004d592328c Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 11 Apr 2024 02:27:25 +0000 Subject: Done with consolidating chan related docs except chan copy --- doc/chan.n | 44 ++++++++++++++++++++++++++++++++++++++--- doc/close.n | 1 + doc/seek.n | 66 +++---------------------------------------------------------- doc/tell.n | 30 +--------------------------- 4 files changed, 46 insertions(+), 95 deletions(-) diff --git a/doc/chan.n b/doc/chan.n index 4054da6..977e084 100644 --- a/doc/chan.n +++ b/doc/chan.n @@ -814,7 +814,44 @@ set data [chan read $f $numDataBytes] close $f .CE - +.SS "FILE SEEK EXAMPLES" +.PP +Read a file twice: +.PP +.CS +set f [open file.txt] +set data1 [chan read $f] +\fBchan seek\fR $f 0 +set data2 [chan read $f] +chan close $f +# $data1 eq $data2 if the file wasn't updated +.CE +.PP +Read the last 10 bytes from a file: +.PP +.CS +set f [open file.data] +# This is guaranteed to work with binary data but +# may fail with other encodings... +chan configure $f -translation binary +\fBchan seek\fR $f -10 end +set data [chan read $f 10] +chan close $f +.CE +.PP +Read a line from a file channel only if it starts with \fBfoobar\fR: +.PP +.CS +# Save the offset in case we need to undo the read... +set offset [\fBtell\fR $chan] +if {[read $chan 6] eq "foobar"} { + gets $chan line +} else { + set line {} + # Undo the read... + seek $chan $offset +} +.CE .SS "ENCODING ERROR EXAMPLES" .PP The example below illustrates handling of an encoding error encountered @@ -980,10 +1017,11 @@ vwait done .SH "SEE ALSO" close(n), eof(n), fblocked(n), fconfigure(n), fcopy(n), file(n), fileevent(n), flush(n), gets(n), open(n), puts(n), read(n), seek(n), -socket(n), tell(n), refchan(n), transchan(n) +socket(n), tell(n), refchan(n), transchan(n), +Tcl_StandardChannels(3) .SH KEYWORDS blocking, channel, end of file, events, input, non-blocking, -offset, output, readable, writable +offset, output, readable, seek, stdio, tell, writable '\" Local Variables: '\" mode: nroff '\" End: diff --git a/doc/close.n b/doc/close.n index 900679e..0851608 100644 --- a/doc/close.n +++ b/doc/close.n @@ -15,6 +15,7 @@ close \- Close an open channel \fBclose \fIchannelId\fR ?\fBr\fR(\fBead\fR)|\fBw\fR(\fBrite\fR)? .BE .SH DESCRIPTION +.PP The \fBclose\fR command has been superceded by the \fBchan close\fR command and supports the same syntax and options. .SH "SEE ALSO" diff --git a/doc/seek.n b/doc/seek.n index 68d40f7..cfd05ea 100644 --- a/doc/seek.n +++ b/doc/seek.n @@ -16,70 +16,10 @@ seek \- Change the access position for an open channel .BE .SH DESCRIPTION .PP -Changes the current access position for \fIchannelId\fR. -.PP -\fIChannelId\fR must be an identifier for an open channel such as a -Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), -the return value from an invocation of \fBopen\fR or \fBsocket\fR, or -the result of a channel creation command provided by a Tcl extension. -.PP -The \fIoffset\fR and \fIorigin\fR -arguments specify the position at which the next read or write will occur -for \fIchannelId\fR. \fIOffset\fR must be an integer (which may be -negative) and \fIorigin\fR must be one of the following: -.IP \fBstart\fR 10 -The new access position will be \fIoffset\fR bytes from the start -of the underlying file or device. -.IP \fBcurrent\fR 10 -The new access position will be \fIoffset\fR bytes from the current -access position; a negative \fIoffset\fR moves the access position -backwards in the underlying file or device. -.IP \fBend\fR 10 -The new access position will be \fIoffset\fR bytes from the end of -the file or device. A negative \fIoffset\fR places the access position -before the end of file, and a positive \fIoffset\fR places the access -position after the end of file. -.PP -The \fIorigin\fR argument defaults to \fBstart\fR. -.PP -The command flushes all buffered output for the channel before the command -returns, even if the channel is in non-blocking mode. -It also discards any buffered and unread input. -This command returns an empty string. -An error occurs if this command is applied to channels whose underlying -file or device does not support seeking. -.PP -Note that \fIoffset\fR values are byte offsets, not character -offsets. Both \fBseek\fR and \fBtell\fR operate in terms of bytes, -not characters, unlike \fBread\fR. -.SH EXAMPLES -.PP -Read a file twice: -.PP -.CS -set f [open file.txt] -set data1 [read $f] -\fBseek\fR $f 0 -set data2 [read $f] -close $f -# $data1 eq $data2 if the file wasn't updated -.CE -.PP -Read the last 10 bytes from a file: -.PP -.CS -set f [open file.data] -# This is guaranteed to work with binary data but -# may fail with other encodings... -fconfigure $f -translation binary -\fBseek\fR $f -10 end -set data [read $f 10] -close $f -.CE +The \fBseek\fR command has been superceded by the \fBchan seek\fR +command and supports the same syntax and options. .SH "SEE ALSO" -file(n), open(n), close(n), gets(n), tell(n), Tcl_StandardChannels(3) -.SH KEYWORDS -access position, file, seek +chan(n) '\" Local Variables: '\" mode: nroff '\" fill-column: 78 diff --git a/doc/tell.n b/doc/tell.n index 54fbae1..1e91708 100644 --- a/doc/tell.n +++ b/doc/tell.n @@ -16,36 +16,8 @@ tell \- Return current access position for an open channel .BE .SH DESCRIPTION .PP -Returns an integer giving the current access position in -\fIchannelId\fR. This value returned is a byte offset that can be passed to -\fBseek\fR in order to set the channel to a particular position. Note -that this value is in terms of bytes, not characters like \fBread\fR. -The value returned is -1 for channels that do not support -seeking. -.PP -\fIChannelId\fR must be an identifier for an open channel such as a -Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), -the return value from an invocation of \fBopen\fR or \fBsocket\fR, or -the result of a channel creation command provided by a Tcl extension. -.SH EXAMPLE -.PP -Read a line from a file channel only if it starts with \fBfoobar\fR: -.PP -.CS -# Save the offset in case we need to undo the read... -set offset [\fBtell\fR $chan] -if {[read $chan 6] eq "foobar"} { - gets $chan line -} else { - set line {} - # Undo the read... - seek $chan $offset -} -.CE .SH "SEE ALSO" -file(n), open(n), close(n), gets(n), seek(n), Tcl_StandardChannels(3) -.SH KEYWORDS -access position, channel, seeking +chan(n) '\" Local Variables: '\" mode: nroff '\" fill-column: 78 -- cgit v0.12 From cb229ebf2ce1a8fbda9a6e7413b1b1c2b301ee2c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 11 Apr 2024 08:00:53 +0000 Subject: Add O_ACCMODE fow Windows, in case it is not defined --- win/tclWinPort.h | 3 +++ 1 file changed, 3 insertions(+) diff --git a/win/tclWinPort.h b/win/tclWinPort.h index f549420..c17cada 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -345,6 +345,9 @@ typedef DWORD_PTR * PDWORD_PTR; #ifndef R_OK # define R_OK 04 #endif +#ifndef O_ACCMODE +# define O_ACCMODE (O_RDONLY | O_WRONLY | O_RDWR) +#endif /* * Define macros to query file type bits, if they're not already -- cgit v0.12 From b8eff9b2453f1d9081a5cf93397e777ddbe47440 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 11 Apr 2024 08:55:01 +0000 Subject: Use Tcl_NewBooleanObj for booleans; we should say what we mean --- generic/tclClock.c | 2 +- generic/tclCmdIL.c | 4 ++-- generic/tclOOInfo.c | 4 ++-- generic/tclZlib.c | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index 391a839..026c47b 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -1139,7 +1139,7 @@ ClockConfigureObjCmd( } if (i+1 >= objc) { Tcl_SetObjResult(interp, - Tcl_NewWideIntObj(dataPtr->defFlags & CLF_VALIDATE ? 1 : 0)); + Tcl_NewBooleanObj(dataPtr->defFlags & CLF_VALIDATE)); } break; case CLOCK_CLEAR_CACHE: diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index f5065f3..a7437af 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -989,7 +989,7 @@ InfoDefaultCmd( if (valueObjPtr == NULL) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); } else { Tcl_Obj *nullObjPtr; TclNewObj(nullObjPtr); @@ -999,7 +999,7 @@ InfoDefaultCmd( if (valueObjPtr == NULL) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); } return TCL_OK; } diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index eba658b..39a4598 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -211,11 +211,11 @@ InfoObjectClassCmd( continue; } if (TclOOIsReachable(o2clsPtr, mixinPtr)) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); return TCL_OK; } } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj( + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( TclOOIsReachable(o2clsPtr, oPtr->selfCls))); return TCL_OK; } diff --git a/generic/tclZlib.c b/generic/tclZlib.c index a3be307..550eef8 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2706,7 +2706,7 @@ ZlibStreamCmd( Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_ZlibStreamEof(zstream))); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_ZlibStreamEof(zstream))); return TCL_OK; case zs_checksum: /* $strm checksum */ if (objc != 2) { -- cgit v0.12 From c04d61ad4b5c3d2fcdbe941830926e10d0bb470d Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 12 Apr 2024 14:10:36 +0000 Subject: Clock not weak; clock strong! --- generic/tclClock.c | 2 +- generic/tclClockFmt.c | 18 +++++++++--------- generic/tclDate.h | 4 ++-- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index 0376a2d..6bb85f4 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -3705,7 +3705,7 @@ ClockScanCommit( { /* If needed assemble julianDay using year, month, etc. */ if (info->flags & CLF_ASSEMBLE_JULIANDAY) { - if ((info->flags & CLF_ISO8601WEAK)) { + if (info->flags & CLF_ISO8601WEEK) { GetJulianDayFromEraYearWeekDay(&yydate, GREGORIAN_CHANGE_DATE); } else if (!(info->flags & CLF_DAYOFYEAR) /* no day of year */ || (info->flags & (CLF_DAYOFMONTH|CLF_MONTH)) /* yymmdd over yyddd */ diff --git a/generic/tclClockFmt.c b/generic/tclClockFmt.c index acb1502..40c6c92 100644 --- a/generic/tclClockFmt.c +++ b/generic/tclClockFmt.c @@ -2008,7 +2008,7 @@ static const ClockScanTokenMap ScnSTokenMap[] = { {CTOKT_INT, CLF_ISO8601YEAR | CLF_ISO8601CENTURY, 0, 4, 4, offsetof(DateInfo, date.iso8601Year), NULL, NULL}, /* %V */ - {CTOKT_INT, CLF_ISO8601WEAK, 0, 1, 2, offsetof(DateInfo, date.iso8601Week), + {CTOKT_INT, CLF_ISO8601WEEK, 0, 1, 2, offsetof(DateInfo, date.iso8601Week), NULL, NULL}, /* %a %A %u %w */ {CTOKT_PARSER, CLF_DAYOFWEEK, 0, 0, 0xffff, 0, @@ -2580,7 +2580,7 @@ ClockScan( case CLF_DAYOFYEAR: /* ddd over naked weekday */ if (!(flags & CLF_ISO8601YEAR)) { - flags &= ~CLF_ISO8601WEAK; + flags &= ~CLF_ISO8601WEEK; } break; case CLF_MONTH | CLF_DAYOFYEAR | CLF_DAYOFMONTH: @@ -2589,7 +2589,7 @@ ClockScan( case CLF_DAYOFMONTH: /* mmdd / dd over naked weekday */ if (!(flags & CLF_ISO8601YEAR)) { - flags &= ~CLF_ISO8601WEAK; + flags &= ~CLF_ISO8601WEEK; } break; /* neither mmdd nor ddd available */ @@ -2597,22 +2597,22 @@ ClockScan( /* but we have day of the week, which can be used */ if (flags & CLF_DAYOFWEEK) { /* prefer week based calculation of julianday */ - flags |= CLF_ISO8601WEAK; + flags |= CLF_ISO8601WEEK; } } /* YearWeekDay below YearMonthDay */ - if ((flags & CLF_ISO8601WEAK) + if ((flags & CLF_ISO8601WEEK) && ((flags & (CLF_YEAR | CLF_DAYOFYEAR)) == (CLF_YEAR | CLF_DAYOFYEAR) || (flags & (CLF_YEAR | CLF_DAYOFMONTH | CLF_MONTH)) == ( CLF_YEAR | CLF_DAYOFMONTH | CLF_MONTH))) { /* yy precedence below yyyy */ if (!(flags & CLF_ISO8601CENTURY) && (flags & CLF_CENTURY)) { /* normally precedence of ISO is higher, but no century - so put it down */ - flags &= ~CLF_ISO8601WEAK; + flags &= ~CLF_ISO8601WEEK; } else if (!(flags & CLF_ISO8601YEAR)) { /* yymmdd or yyddd over naked weekday */ - flags &= ~CLF_ISO8601WEAK; + flags &= ~CLF_ISO8601WEEK; } } @@ -2628,7 +2628,7 @@ ClockScan( } } } - if (flags & (CLF_ISO8601WEAK | CLF_ISO8601YEAR)) { + if (flags & (CLF_ISO8601WEEK | CLF_ISO8601YEAR)) { if ((flags & (CLF_ISO8601YEAR | CLF_YEAR)) == CLF_YEAR) { /* for calculations expected iso year */ info->date.iso8601Year = yyYear; @@ -2643,7 +2643,7 @@ ClockScan( } } if ((flags & (CLF_ISO8601YEAR | CLF_YEAR)) == CLF_ISO8601YEAR) { - /* for calculations expected year (e. g. CLF_ISO8601WEAK not set) */ + /* for calculations expected year (e. g. CLF_ISO8601WEEK not set) */ yyYear = info->date.iso8601Year; } } diff --git a/generic/tclDate.h b/generic/tclDate.h index 60e07ab..1657528 100644 --- a/generic/tclDate.h +++ b/generic/tclDate.h @@ -45,7 +45,7 @@ enum DateInfoFlags { CLF_YEAR = 1 << 10, CLF_DAYOFWEEK = 1 << 11, CLF_ISO8601YEAR = 1 << 12, - CLF_ISO8601WEAK = 1 << 13, + CLF_ISO8601WEEK = 1 << 13, CLF_ISO8601CENTURY = 1 << 14, CLF_SIGNED = 1 << 15, @@ -55,7 +55,7 @@ enum DateInfoFlags { CLF_HAVEDATE = (CLF_DAYOFMONTH | CLF_MONTH | CLF_YEAR), CLF_DATE = (CLF_JULIANDAY | CLF_DAYOFMONTH | CLF_DAYOFYEAR | CLF_MONTH | CLF_YEAR | CLF_ISO8601YEAR - | CLF_DAYOFWEEK | CLF_ISO8601WEAK), + | CLF_DAYOFWEEK | CLF_ISO8601WEEK), /* * Extra flags used outside of scan/format-tokens too (int, not a short). -- cgit v0.12 From 8d186d9f5a98a5225ca38935c3cd51d33236f1c6 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 12 Apr 2024 16:09:49 +0000 Subject: Clean up the arith series code, including fixing a memory leak --- generic/tclArithSeries.c | 426 +++++++++++++++++++++++++++-------------------- 1 file changed, 250 insertions(+), 176 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 2770639..fd1014c 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -46,41 +46,56 @@ * Note that the len can in theory be always computed by start,end,step * but it's faster to cache it inside the internal representation. */ + typedef struct { Tcl_Size len; Tcl_Obj **elements; int isDouble; +} ArithSeries; + +typedef struct { + ArithSeries base; Tcl_WideInt start; Tcl_WideInt end; Tcl_WideInt step; -} ArithSeries; +} ArithSeriesInt; + typedef struct { - Tcl_Size len; - Tcl_Obj **elements; - int isDouble; + ArithSeries base; double start; double end; double step; - int precision; + unsigned precision; /* Number of decimal places to render. */ } ArithSeriesDbl; -/* -------------------------- ArithSeries object ---------------------------- */ - -static int TclArithSeriesObjIndex(TCL_UNUSED(Tcl_Interp *), Tcl_Obj *arithSeriesObj, - Tcl_Size index, Tcl_Obj **elemObj); - -static Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesObj); -static int TclArithSeriesObjRange(Tcl_Interp *interp, Tcl_Obj *arithSeriesObj, - Tcl_Size fromIdx, Tcl_Size toIdx, Tcl_Obj **newObjPtr); -static int TclArithSeriesObjReverse(Tcl_Interp *interp, Tcl_Obj *arithSeriesObj, Tcl_Obj **newObjPtr); -static int TclArithSeriesGetElements(Tcl_Interp *interp, - Tcl_Obj *objPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); -static void DupArithSeriesInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -static void FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr); -static void UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr); -static int SetArithSeriesFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); -static int ArithSeriesInOperation(Tcl_Interp *interp, Tcl_Obj *valueObj, Tcl_Obj *arithSeriesObj, - int *boolResult); +/* Forward declarations. */ + +static int TclArithSeriesObjIndex(TCL_UNUSED(Tcl_Interp *), + Tcl_Obj *arithSeriesObj, Tcl_Size index, + Tcl_Obj **elemObj); +static Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesObj); +static int TclArithSeriesObjRange(Tcl_Interp *interp, + Tcl_Obj *arithSeriesObj, Tcl_Size fromIdx, + Tcl_Size toIdx, Tcl_Obj **newObjPtr); +static int TclArithSeriesObjReverse(Tcl_Interp *interp, + Tcl_Obj *arithSeriesObj, Tcl_Obj **newObjPtr); +static int TclArithSeriesGetElements(Tcl_Interp *interp, + Tcl_Obj *objPtr, Tcl_Size *objcPtr, + Tcl_Obj ***objvPtr); +static void DupArithSeriesInternalRep(Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr); +static void FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr); +static void UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr); +static int SetArithSeriesFromAny(Tcl_Interp *interp, + Tcl_Obj *objPtr); +static int ArithSeriesInOperation(Tcl_Interp *interp, + Tcl_Obj *valueObj, Tcl_Obj *arithSeriesObj, + int *boolResult); +static int TclArithSeriesObjStep(Tcl_Obj *arithSeriesObj, + Tcl_Obj **stepObj); + +/* ------------------------ ArithSeries object type -------------------------- */ + static const Tcl_ObjType arithSeriesType = { "arithseries", /* name */ FreeArithSeriesInternalRep, /* freeIntRepProc */ @@ -97,10 +112,11 @@ static const Tcl_ObjType arithSeriesType = { NULL, // Replace ArithSeriesInOperation) // "in" operator }; - + /* * Helper functions * + * - power10 -- Fast version of pow(10, (int) n) for common cases. * - ArithRound -- Round doubles to the number of significant fractional * digits * - ArithSeriesIndexDbl -- base list indexing operation for doubles @@ -111,10 +127,31 @@ static const Tcl_ObjType arithSeriesType = { * - maxPrecision -- Using the values provide, determine the longest percision * in the arithSeries */ + static inline double -ArithRound(double d, unsigned int n) { - double scalefactor = pow(10, n); - return round(d*scalefactor)/scalefactor; +power10( + unsigned n) +{ + static const double powers[] = { + 1, 10, 100, 1000, 1e4, 1e5, 1e6, 1e7, 1e8, 1e9, 1e10, 1e11, 1e12, + 1e13, 1e14, 1e15, 1e16, 1e17, 1e18, 1e19, 1e20 + }; + + if (n < sizeof(powers) / sizeof(*powers)) { + return powers[n]; + } else { + // Not an expected case. Doesn't need to be so fast + return pow(10, n); + } +} + +static inline double +ArithRound( + double d, + unsigned n) +{ + double scalefactor = power10(n); + return round(d * scalefactor) / scalefactor; } static inline double @@ -122,13 +159,14 @@ ArithSeriesIndexDbl( ArithSeries *arithSeriesRepPtr, Tcl_WideInt index) { - ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl*)arithSeriesRepPtr; if (arithSeriesRepPtr->isDouble) { + ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl *) arithSeriesRepPtr; double d = dblRepPtr->start + (index * dblRepPtr->step); - unsigned n = (dblRepPtr->precision > 0 ? dblRepPtr->precision : 0); - return ArithRound(d, n); + + return ArithRound(d, dblRepPtr->precision); } else { - return (double)(arithSeriesRepPtr->start + (index * arithSeriesRepPtr->step)); + ArithSeriesInt *intRepPtr = (ArithSeriesInt *) arithSeriesRepPtr; + return (double)(intRepPtr->start + (index * intRepPtr->step)); } } @@ -137,51 +175,57 @@ ArithSeriesIndexInt( ArithSeries *arithSeriesRepPtr, Tcl_WideInt index) { - ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl*)arithSeriesRepPtr; if (arithSeriesRepPtr->isDouble) { - return (Tcl_WideInt)(dblRepPtr->start + ((index) * dblRepPtr->step)); + ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl *) arithSeriesRepPtr; + return (Tcl_WideInt) (dblRepPtr->start + (index * dblRepPtr->step)); } else { - return (arithSeriesRepPtr->start + (index * arithSeriesRepPtr->step)); + ArithSeriesInt *intRepPtr = (ArithSeriesInt *) arithSeriesRepPtr; + return intRepPtr->start + (index * intRepPtr->step); } } -static inline ArithSeries* -ArithSeriesGetInternalRep(Tcl_Obj *objPtr) +static inline ArithSeries * +ArithSeriesGetInternalRep( + Tcl_Obj *objPtr) { - const Tcl_ObjInternalRep *irPtr; - irPtr = TclFetchInternalRep((objPtr), &arithSeriesType); - return irPtr ? (ArithSeries *)irPtr->twoPtrValue.ptr1 : NULL; + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, + &arithSeriesType); + return irPtr ? (ArithSeries *) irPtr->twoPtrValue.ptr1 : NULL; } /* - * Compute number of significant factional digits + * Compute number of significant fractional digits */ -static inline int -Precision(double d) +static inline unsigned +Precision( + double d) { - char tmp[TCL_DOUBLE_SPACE+2], *off; + char tmp[TCL_DOUBLE_SPACE + 2], *off; + tmp[0] = 0; - Tcl_PrintDouble(NULL,d,tmp); + Tcl_PrintDouble(NULL, d, tmp); off = strchr(tmp, '.'); - return (off ? strlen(off+1) : 0); + return (off ? strlen(off + 1) : 0); } /* * Find longest number of digits after the decimal point. */ -static inline int -maxPrecision(double start, double end, double step) +static inline unsigned +maxPrecision( + double start, + double end, + double step) { - int dp = Precision(step); - int i = Precision(start); + unsigned dp = Precision(step); + unsigned i = Precision(start); + dp = i>dp ? i : dp; i = Precision(end); dp = i>dp ? i : dp; return dp; } - -static int TclArithSeriesObjStep(Tcl_Obj *arithSeriesObj, Tcl_Obj **stepObj); - + /* *---------------------------------------------------------------------- * @@ -206,31 +250,38 @@ static int TclArithSeriesObjStep(Tcl_Obj *arithSeriesObj, Tcl_Obj **stepObj); *---------------------------------------------------------------------- */ static Tcl_WideInt -ArithSeriesLenInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step) +ArithSeriesLenInt( + Tcl_WideInt start, + Tcl_WideInt end, + Tcl_WideInt step) { Tcl_WideInt len; if (step == 0) { return 0; } - len = 1 + ((end-start)/step); + len = 1 + ((end - start) / step); return (len < 0) ? -1 : len; } static Tcl_WideInt -ArithSeriesLenDbl(double start, double end, double step, int precision) +ArithSeriesLenDbl( + double start, + double end, + double step, + unsigned precision) { double istart, iend, istep, ilen; + if (step == 0) { return 0; } - istart = start * pow(10,precision); - iend = end * pow(10,precision); - istep = step * pow(10,precision); - ilen = ((iend-istart+istep)/istep); + istart = start * power10(precision); + iend = end * power10(precision); + istep = step * power10(precision); + ilen = (iend - istart + istep) / istep; return floor(ilen); } - /* *---------------------------------------------------------------------- @@ -239,6 +290,7 @@ ArithSeriesLenDbl(double start, double end, double step, int precision) * * Initialize the internal representation of a arithseries Tcl_Obj to a * copy of the internal representation of an existing arithseries object. + * The copy does not share the cache of the elements. * * Results: * None. @@ -246,6 +298,7 @@ ArithSeriesLenDbl(double start, double end, double step, int precision) * Side effects: * We set "copyPtr"s internal rep to a pointer to a * newly allocated ArithSeries structure. + * *---------------------------------------------------------------------- */ @@ -254,26 +307,25 @@ DupArithSeriesInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - ArithSeries *srcArithSeriesRepPtr = - (ArithSeries *) srcPtr->internalRep.twoPtrValue.ptr1; + ArithSeries *srcRepPtr = (ArithSeries *) + srcPtr->internalRep.twoPtrValue.ptr1; - /* - * Allocate a new ArithSeries structure. */ - - if (srcArithSeriesRepPtr->isDouble) { - ArithSeriesDbl *srcArithSeriesDblRepPtr = - (ArithSeriesDbl *)srcArithSeriesRepPtr; - ArithSeriesDbl *copyArithSeriesDblRepPtr = - (ArithSeriesDbl *)Tcl_Alloc(sizeof(ArithSeriesDbl)); - *copyArithSeriesDblRepPtr = *srcArithSeriesDblRepPtr; - copyArithSeriesDblRepPtr->elements = NULL; - copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesDblRepPtr; + if (srcRepPtr->isDouble) { + ArithSeriesDbl *srcDblPtr = (ArithSeriesDbl *) srcRepPtr; + ArithSeriesDbl *copyDblPtr = (ArithSeriesDbl *) + Tcl_Alloc(sizeof(ArithSeriesDbl)); + + *copyDblPtr = *srcDblPtr; + copyDblPtr->base.elements = NULL; + copyPtr->internalRep.twoPtrValue.ptr1 = copyDblPtr; } else { - ArithSeries *copyArithSeriesRepPtr = - (ArithSeries *)Tcl_Alloc(sizeof(ArithSeries)); - *copyArithSeriesRepPtr = *srcArithSeriesRepPtr; - copyArithSeriesRepPtr->elements = NULL; - copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr; + ArithSeriesInt *srcIntPtr = (ArithSeriesInt *) srcRepPtr; + ArithSeriesInt *copyIntPtr = (ArithSeriesInt *) + Tcl_Alloc(sizeof(ArithSeriesInt)); + + *copyIntPtr = *srcIntPtr; + copyIntPtr->base.elements = NULL; + copyPtr->internalRep.twoPtrValue.ptr1 = copyIntPtr; } copyPtr->internalRep.twoPtrValue.ptr2 = NULL; copyPtr->typePtr = &arithSeriesType; @@ -293,24 +345,34 @@ DupArithSeriesInternalRep( * *---------------------------------------------------------------------- */ -static void -FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr) /* Free any allocated memory */ + +static inline void +FreeElements( + ArithSeries *arithSeriesRepPtr) { - ArithSeries *arithSeriesRepPtr = (ArithSeries*)arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; + if (arithSeriesRepPtr->elements) { + Tcl_WideInt i, len = arithSeriesRepPtr->len; - if (arithSeriesRepPtr) { - if (arithSeriesRepPtr->elements) { - Tcl_WideInt i, len = arithSeriesRepPtr->len; - for (i=0; ielements[i]); - } - Tcl_Free((char*)arithSeriesRepPtr->elements); - arithSeriesRepPtr->elements = NULL; + for (i=0; ielements[i]); } - Tcl_Free((char*)arithSeriesRepPtr); + Tcl_Free((char *) arithSeriesRepPtr->elements); + arithSeriesRepPtr->elements = NULL; } } +static void +FreeArithSeriesInternalRep( + Tcl_Obj *arithSeriesObjPtr) +{ + ArithSeries *arithSeriesRepPtr = (ArithSeries *) + arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; + + if (arithSeriesRepPtr) { + FreeElements(arithSeriesRepPtr); + Tcl_Free((char *) arithSeriesRepPtr); + } +} /* *---------------------------------------------------------------------- @@ -326,17 +388,20 @@ FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr) /* Free any allocated me * A NULL pointer of the range is invalid. * * Side Effects: - * * None. + * *---------------------------------------------------------------------- */ -static -Tcl_Obj * -NewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len) +static Tcl_Obj * +NewArithSeriesInt( + Tcl_WideInt start, + Tcl_WideInt end, + Tcl_WideInt step, + Tcl_WideInt len) { Tcl_WideInt length; Tcl_Obj *arithSeriesObj; - ArithSeries *arithSeriesRepPtr; + ArithSeriesInt *arithSeriesRepPtr; length = len>=0 ? len : -1; if (length < 0) { @@ -349,13 +414,13 @@ NewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_Wide return arithSeriesObj; } - arithSeriesRepPtr = (ArithSeries*)Tcl_Alloc(sizeof (ArithSeries)); - arithSeriesRepPtr->isDouble = 0; + arithSeriesRepPtr = (ArithSeriesInt *) Tcl_Alloc(sizeof(ArithSeriesInt)); + arithSeriesRepPtr->base.len = length; + arithSeriesRepPtr->base.elements = NULL; + arithSeriesRepPtr->base.isDouble = 0; arithSeriesRepPtr->start = start; arithSeriesRepPtr->end = end; arithSeriesRepPtr->step = step; - arithSeriesRepPtr->len = length; - arithSeriesRepPtr->elements = NULL; arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; arithSeriesObj->typePtr = &arithSeriesType; @@ -385,9 +450,12 @@ NewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_Wide *---------------------------------------------------------------------- */ -static -Tcl_Obj * -NewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) +static Tcl_Obj * +NewArithSeriesDbl( + double start, + double end, + double step, + Tcl_WideInt len) { Tcl_WideInt length; Tcl_Obj *arithSeriesObj; @@ -404,14 +472,14 @@ NewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) return arithSeriesObj; } - arithSeriesRepPtr = (ArithSeriesDbl*)Tcl_Alloc(sizeof (ArithSeriesDbl)); - arithSeriesRepPtr->isDouble = 1; + arithSeriesRepPtr = (ArithSeriesDbl *) Tcl_Alloc(sizeof(ArithSeriesDbl)); + arithSeriesRepPtr->base.len = length; + arithSeriesRepPtr->base.elements = NULL; + arithSeriesRepPtr->base.isDouble = 1; arithSeriesRepPtr->start = start; arithSeriesRepPtr->end = end; arithSeriesRepPtr->step = step; - arithSeriesRepPtr->len = length; - arithSeriesRepPtr->elements = NULL; - arithSeriesRepPtr->precision = maxPrecision(start,end,step); + arithSeriesRepPtr->precision = maxPrecision(start, end, step); arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; arithSeriesObj->typePtr = &arithSeriesType; @@ -546,7 +614,7 @@ TclNewArithSeriesObj( assert(dstep!=0); if (!lenObj) { if (useDoubles) { - int precision = maxPrecision(dstart,dend,dstep); + unsigned precision = maxPrecision(dstart, dend, dstep); len = ArithSeriesLenDbl(dstart, dend, dstep, precision); } else { len = ArithSeriesLenInt(start, end, step); @@ -557,21 +625,21 @@ TclNewArithSeriesObj( if (!endObj) { if (useDoubles) { // Compute precision based on given command argument values - int precision = maxPrecision(dstart,len,dstep); + unsigned precision = maxPrecision(dstart, len, dstep); + dend = dstart + (dstep * (len-1)); // Make computed end value match argument(s) precision dend = ArithRound(dend, precision); end = dend; } else { - end = start + (step * (len-1)); + end = start + (step * (len - 1)); dend = end; } } if (len > TCL_SIZE_MAX) { - Tcl_SetObjResult( - interp, - Tcl_NewStringObj("max length of a Tcl list exceeded", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "max length of a Tcl list exceeded", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); return TCL_ERROR; } @@ -606,13 +674,12 @@ TclNewArithSeriesObj( * *---------------------------------------------------------------------- */ - int TclArithSeriesObjIndex( - TCL_UNUSED(Tcl_Interp *),/* Used for error reporting if not NULL. */ - Tcl_Obj *arithSeriesObj, /* List obj */ - Tcl_Size index, /* index to element of interest */ - Tcl_Obj **elemObj) /* Return value */ + TCL_UNUSED(Tcl_Interp *), + Tcl_Obj *arithSeriesObj, /* List obj */ + Tcl_Size index, /* index to element of interest */ + Tcl_Obj **elemObj) /* Return value */ { ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); @@ -651,7 +718,7 @@ Tcl_Size ArithSeriesObjLength( Tcl_Obj *arithSeriesObj) { - ArithSeries *arithSeriesRepPtr = (ArithSeries*) + ArithSeries *arithSeriesRepPtr = (ArithSeries *) arithSeriesObj->internalRep.twoPtrValue.ptr1; return arithSeriesRepPtr->len; } @@ -681,14 +748,15 @@ TclArithSeriesObjStep( Tcl_Obj **stepObj) { ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); + if (arithSeriesRepPtr->isDouble) { - *stepObj = Tcl_NewDoubleObj(((ArithSeriesDbl*)(arithSeriesRepPtr))->step); + *stepObj = Tcl_NewDoubleObj(((ArithSeriesDbl *) arithSeriesRepPtr)->step); } else { - *stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step); + *stepObj = Tcl_NewWideIntObj(((ArithSeriesInt *) arithSeriesRepPtr)->step); } return TCL_OK; } - + /* *---------------------------------------------------------------------- * @@ -773,8 +841,8 @@ TclArithSeriesObjRange( if (toIdx < 0) { toIdx = 0; } - if (toIdx > arithSeriesRepPtr->len-1) { - toIdx = arithSeriesRepPtr->len-1; + if (toIdx > arithSeriesRepPtr->len - 1) { + toIdx = arithSeriesRepPtr->len - 1; } TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx, &startObj); @@ -806,30 +874,31 @@ TclArithSeriesObjRange( TclInvalidateStringRep(arithSeriesObj); if (arithSeriesRepPtr->isDouble) { - ArithSeriesDbl *arithSeriesDblRepPtr = (ArithSeriesDbl*)arithSeriesRepPtr; + ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl *) arithSeriesRepPtr; double start, end, step; Tcl_GetDoubleFromObj(NULL, startObj, &start); Tcl_GetDoubleFromObj(NULL, endObj, &end); Tcl_GetDoubleFromObj(NULL, stepObj, &step); - arithSeriesDblRepPtr->start = start; - arithSeriesDblRepPtr->end = end; - arithSeriesDblRepPtr->step = step; - arithSeriesDblRepPtr->precision = maxPrecision(start, end, step); - arithSeriesDblRepPtr->len = - ArithSeriesLenDbl(start, end, step, arithSeriesDblRepPtr->precision); - arithSeriesDblRepPtr->elements = NULL; - + dblRepPtr->start = start; + dblRepPtr->end = end; + dblRepPtr->step = step; + dblRepPtr->precision = maxPrecision(start, end, step); + FreeElements(arithSeriesRepPtr); + dblRepPtr->base.len = + ArithSeriesLenDbl(start, end, step, dblRepPtr->precision); } else { + ArithSeriesInt *intRepPtr = (ArithSeriesInt *) arithSeriesRepPtr; Tcl_WideInt start, end, step; + Tcl_GetWideIntFromObj(NULL, startObj, &start); Tcl_GetWideIntFromObj(NULL, endObj, &end); Tcl_GetWideIntFromObj(NULL, stepObj, &step); - arithSeriesRepPtr->start = start; - arithSeriesRepPtr->end = end; - arithSeriesRepPtr->step = step; - arithSeriesRepPtr->len = ArithSeriesLenInt(start, end, step); - arithSeriesRepPtr->elements = NULL; + intRepPtr->start = start; + intRepPtr->end = end; + intRepPtr->step = step; + FreeElements(arithSeriesRepPtr); + intRepPtr->base.len = ArithSeriesLenInt(start, end, step); } Tcl_DecrRefCount(startObj); @@ -880,32 +949,32 @@ TclArithSeriesGetElements( * pointers to the list's objects. */ { if (TclHasInternalRep(objPtr, &arithSeriesType)) { - ArithSeries *arithSeriesRepPtr; + ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(objPtr); Tcl_Obj **objv; - int i, objc; - - arithSeriesRepPtr = ArithSeriesGetInternalRep(objPtr); + Tcl_Size objc = arithSeriesRepPtr->len; - objc = arithSeriesRepPtr->len; if (objc > 0) { if (arithSeriesRepPtr->elements) { /* If this exists, it has already been populated */ objv = arithSeriesRepPtr->elements; } else { /* Construct the elements array */ - objv = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*) * objc); + objv = (Tcl_Obj **) Tcl_Alloc(sizeof(Tcl_Obj*) * objc); if (objv == NULL) { if (interp) { - Tcl_SetObjResult( - interp, - Tcl_NewStringObj("max length of a Tcl list exceeded", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "max length of a Tcl list exceeded", + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return TCL_ERROR; } arithSeriesRepPtr->elements = objv; + + Tcl_Size i; for (i = 0; i < objc; i++) { int status = TclArithSeriesObjIndex(interp, objPtr, i, &objv[i]); + if (status) { return TCL_ERROR; } @@ -919,7 +988,8 @@ TclArithSeriesGetElements( *objcPtr = objc; } else { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("value is not an arithseries", TCL_INDEX_NONE)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "value is not an arithseries", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", (void *)NULL); } return TCL_ERROR; @@ -968,7 +1038,7 @@ TclArithSeriesObjReverse( isDouble = arithSeriesRepPtr->isDouble; len = arithSeriesRepPtr->len; - TclArithSeriesObjIndex(NULL, arithSeriesObj, (len-1), &startObj); + TclArithSeriesObjIndex(NULL, arithSeriesObj, len - 1, &startObj); Tcl_IncrRefCount(startObj); TclArithSeriesObjIndex(NULL, arithSeriesObj, 0, &endObj); Tcl_IncrRefCount(endObj); @@ -991,6 +1061,7 @@ TclArithSeriesObjReverse( if (Tcl_IsShared(arithSeriesObj) || (arithSeriesObj->refCount > 1)) { Tcl_Obj *lenObj; + TclNewIntObj(lenObj, len); if (TclNewArithSeriesObj(NULL, &resultObj, isDouble, startObj, endObj, stepObj, lenObj) != TCL_OK) { @@ -998,7 +1069,6 @@ TclArithSeriesObjReverse( } Tcl_DecrRefCount(lenObj); } else { - /* * In-place is possible. */ @@ -1006,25 +1076,18 @@ TclArithSeriesObjReverse( TclInvalidateStringRep(arithSeriesObj); if (isDouble) { - ArithSeriesDbl *arithSeriesDblRepPtr = - (ArithSeriesDbl*)arithSeriesRepPtr; - arithSeriesDblRepPtr->start = dstart; - arithSeriesDblRepPtr->end = dend; - arithSeriesDblRepPtr->step = dstep; + ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl *) arithSeriesRepPtr; + + dblRepPtr->start = dstart; + dblRepPtr->end = dend; + dblRepPtr->step = dstep; } else { - arithSeriesRepPtr->start = start; - arithSeriesRepPtr->end = end; - arithSeriesRepPtr->step = step; - } - if (arithSeriesRepPtr->elements) { - Tcl_WideInt i; - for (i=0; ielements[i]); - } - Tcl_Free((char*)arithSeriesRepPtr->elements); + ArithSeriesInt *intRepPtr = (ArithSeriesInt *) arithSeriesRepPtr; + intRepPtr->start = start; + intRepPtr->end = end; + intRepPtr->step = step; } - arithSeriesRepPtr->elements = NULL; - + FreeElements(arithSeriesRepPtr); resultObj = arithSeriesObj; } @@ -1064,11 +1127,12 @@ TclArithSeriesObjReverse( * *---------------------------------------------------------------------- */ - static void -UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr) +UpdateStringOfArithSeries( + Tcl_Obj *arithSeriesObjPtr) { - ArithSeries *arithSeriesRepPtr = (ArithSeries*)arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; + ArithSeries *arithSeriesRepPtr = (ArithSeries *) + arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; char *p; Tcl_Obj *eleObj; Tcl_Size i, bytlen = 0; @@ -1078,14 +1142,16 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr) */ if (!arithSeriesRepPtr->isDouble) { for (i = 0; i < arithSeriesRepPtr->len; i++) { - double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i); - size_t slen = d>0 ? log10(d)+1 : d<0 ? log10((0-d))+2 : 1; + double d = ArithSeriesIndexInt(arithSeriesRepPtr, i); + size_t slen = d>0 ? log10(d)+1 : d<0 ? log10(-d)+2 : 1; + bytlen += slen; } } else { for (i = 0; i < arithSeriesRepPtr->len; i++) { double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i); - char tmp[TCL_DOUBLE_SPACE+2]; + char tmp[TCL_DOUBLE_SPACE + 2]; + tmp[0] = 0; Tcl_PrintDouble(NULL,d,tmp); if ((bytlen + strlen(tmp)) > TCL_SIZE_MAX) { @@ -1105,6 +1171,7 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr) if (TclArithSeriesObjIndex(NULL, arithSeriesObjPtr, i, &eleObj) == TCL_OK) { Tcl_Size slen; char *str = TclGetStringFromObj(eleObj, &slen); + strcpy(p, str); p[slen] = ' '; p += slen + 1; @@ -1143,12 +1210,13 @@ ArithSeriesInOperation( Tcl_Obj *arithSeriesObjPtr, int *boolResult) { - ArithSeries *arithSeriesRepPtr = (ArithSeries*)arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; - ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl*)arithSeriesRepPtr; + ArithSeries *repPtr = (ArithSeries *) + arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; int status; Tcl_Size index, incr, elen, vlen; - if (arithSeriesRepPtr->isDouble) { + if (repPtr->isDouble) { + ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl *) repPtr; double y; int test = 0; @@ -1161,9 +1229,12 @@ ArithSeriesInOperation( index = (y - dblRepPtr->start) / dblRepPtr->step; while (incr<2) { Tcl_Obj *elemObj; + elen = 0; TclArithSeriesObjIndex(interp, arithSeriesObjPtr, (index+incr), &elemObj); + const char *estr = elemObj ? TclGetStringFromObj(elemObj, &elen) : ""; + /* "in" operation defined as a string compare */ test = (elen == vlen) ? (memcmp(estr, vstr, elen) == 0) : 0; Tcl_BounceRefCount(elemObj); @@ -1178,7 +1249,7 @@ ArithSeriesInOperation( *boolResult = test; } } else { - ArithSeries *intRepPtr = arithSeriesRepPtr; + ArithSeriesInt *intRepPtr = (ArithSeriesInt *) repPtr; Tcl_WideInt y; status = Tcl_GetWideIntFromObj(NULL, valueObj, &y); @@ -1188,11 +1259,14 @@ ArithSeriesInOperation( } } else { Tcl_Obj *elemObj; + elen = 0; index = (y - intRepPtr->start) / intRepPtr->step; TclArithSeriesObjIndex(interp, arithSeriesObjPtr, index, &elemObj); + char const *vstr = TclGetStringFromObj(valueObj, &vlen); char const *estr = elemObj ? TclGetStringFromObj(elemObj, &elen) : ""; + if (boolResult) { *boolResult = (elen == vlen) ? (memcmp(estr, vstr, elen) == 0) : 0; } -- cgit v0.12 From 1ce5d3750ae59ed681763f17e204045c835775c2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 12 Apr 2024 16:41:00 +0000 Subject: In Tcl 9, we don't need "-encoding utf-8" here any more --- library/safe.tcl | 4 ++-- unix/Makefile.in | 2 +- win/Makefile.in | 2 +- win/makefile.vc | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index 80bb227..cc4a194 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -623,14 +623,14 @@ proc ::safe::InterpInit { # other procedures defined: if {[catch {::interp eval $child { - source -encoding utf-8 [file join $tcl_library init.tcl] + source [file join $tcl_library init.tcl] }} msg opt]} { Log $child "can't source init.tcl ($msg)" return -options $opt "can't source init.tcl into child $child ($msg)" } if {[catch {::interp eval $child { - source -encoding utf-8 [file join $tcl_library tm.tcl] + source [file join $tcl_library tm.tcl] }} msg opt]} { Log $child "can't source tm.tcl ($msg)" return -options $opt "can't source tm.tcl into child $child ($msg)" diff --git a/unix/Makefile.in b/unix/Makefile.in index e06f749..801a3f5 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -2488,7 +2488,7 @@ html-tk: ${NATIVE_TCLSH} @EXTRA_BUILD_HTML@ BUILD_HTML = \ - @${NATIVE_TCLSH} -encoding utf-8 $(TOOL_DIR)/tcltk-man2html.tcl \ + @${NATIVE_TCLSH} $(TOOL_DIR)/tcltk-man2html.tcl \ --useversion=$(MAJOR_VERSION).$(MINOR_VERSION) \ --htmldir="$(HTML_INSTALL_DIR)" \ --srcdir=$(TOP_DIR) $(BUILD_HTML_FLAGS) diff --git a/win/Makefile.in b/win/Makefile.in index 799c584..14e518e 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -1020,7 +1020,7 @@ runtest: tcltest # `make shell SCRIPT=foo.tcl` shell: binaries @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - $(WINE) ./$(TCLSH) -encoding utf-8 $(SCRIPT) + $(WINE) ./$(TCLSH) $(SCRIPT) # This target can be used to run tclsh inside either gdb or insight gdb: binaries diff --git a/win/makefile.vc b/win/makefile.vc index 261e0a2..152fc1e 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -734,7 +734,7 @@ CHMFILE=$(HTMLDIR)\$(HTMLBASE).chm htmlhelp: chmsetup $(CHMFILE) $(CHMFILE): $(DOCDIR)\* - @$(TCLSH) -encoding utf-8 $(TOOLSDIR)\tcltk-man2html.tcl "--htmldir=$(HTMLDIR)" + @$(TCLSH) $(TOOLSDIR)\tcltk-man2html.tcl "--htmldir=$(HTMLDIR)" @echo Compiling HTML help project -"$(HHC)" <<$(HHPFILE) >NUL [OPTIONS] -- cgit v0.12 From 104ed642d8bffb3165f77e197e1e46b72e4d9c82 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 12 Apr 2024 17:15:54 +0000 Subject: Add missing documentation for TIP 598 Tcl_WinConvertError --- doc/SetErrno.3 | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/doc/SetErrno.3 b/doc/SetErrno.3 index abed74e..877a362 100644 --- a/doc/SetErrno.3 +++ b/doc/SetErrno.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_SetErrno, Tcl_GetErrno, Tcl_ErrnoId, Tcl_ErrnoMsg \- manipulate errno to store and retrieve error codes +Tcl_SetErrno, Tcl_GetErrno, Tcl_ErrnoId, Tcl_ErrnoMsg, Tcl_WinConvertError \- manipulate errno to store and retrieve error codes .SH SYNOPSIS .nf \fB#include \fR @@ -23,11 +23,17 @@ const char * .sp const char * \fBTcl_ErrnoMsg\fR(\fIerrorCode\fR) +.sp +void +\fBTcl_WinConvertError\fR(\fIwinErrorCode\fR) .fi .SH ARGUMENTS .AS int errorCode .AP int errorCode in A POSIX error code such as \fBENOENT\fR. +.AS unsigned int winErrorCode in +.AP DWORD winErrorCode in +A Windows or Winsock error code such as \fBERROR_FILE_NOT_FOUND\fR. .BE .SH DESCRIPTION @@ -60,6 +66,9 @@ that corresponds to the value of its typically the value returned by \fBTcl_GetErrno\fR. The strings returned by these functions are statically allocated and the caller must not free or modify them. +.PP +\fBTcl_WinConvertError\fR (Windows only) maps the passed Windows or Winsock +error code to a POSIX error and stores it in \fBerrno\fR. .SH KEYWORDS errno, error code, global variables -- cgit v0.12 From ad2e0465fe3118c3fd64465388032790663abca3 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 12 Apr 2024 19:24:12 +0000 Subject: One added line that ends the "Conditional jump" errors from valgrind --- generic/tclClockFmt.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclClockFmt.c b/generic/tclClockFmt.c index 40c6c92..8e99f20 100644 --- a/generic/tclClockFmt.c +++ b/generic/tclClockFmt.c @@ -560,6 +560,7 @@ ClockFmtScnStorageAllocProc( memset(fss, 0, sizeof(*fss)); hPtr = HashEntry4FmtScn(fss); + hPtr->key.oneWordValue = 0; /* See Ticket [167e0635db] */ memcpy(&hPtr->key.string, string, size); hPtr->clientData = 0; /* currently unused */ -- cgit v0.12 From a4f2ba7f4857c10ed2f89c8db768a544b1dc1520 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 12 Apr 2024 19:37:02 +0000 Subject: A crude protection against accessing the storage after it has been freed by a finalization pass. There are probably better fixes, but this silences the valgrind memory errors. --- generic/tclClockFmt.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclClockFmt.c b/generic/tclClockFmt.c index 8e99f20..e63b642 100644 --- a/generic/tclClockFmt.c +++ b/generic/tclClockFmt.c @@ -679,7 +679,7 @@ ClockFmtObj_FreeInternalRep( Tcl_Obj *objPtr) { ClockFmtScnStorage *fss = ObjClockFmtScn(objPtr); - if (fss != NULL) { + if (fss != NULL && initialized) { Tcl_MutexLock(&ClockFmtMutex); /* decrement object reference count of format/scan storage */ if (--fss->objRefCount <= 0) { -- cgit v0.12 From 8b170cfd056cd0ee91a4dac3a181c2ab3ba581a4 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 12 Apr 2024 19:47:04 +0000 Subject: Plug memory leak of the mcLiterals field. --- generic/tclClock.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclClock.c b/generic/tclClock.c index 6bb85f4..5bfb7c4 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -352,6 +352,7 @@ ClockDeleteCmdProc( for (i = 0; i < MCLIT__END; ++i) { Tcl_DecrRefCount(data->mcLiterals[i]); } + Tcl_Free(data->mcLiterals); data->mcLiterals = NULL; } if (data->mcLitIdxs != NULL) { -- cgit v0.12 From 1443b389750d24693a94978a8665ae6813e8c01d Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 12 Apr 2024 19:51:09 +0000 Subject: Plug mem leak of mcLitIdxs field. --- generic/tclClock.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclClock.c b/generic/tclClock.c index 5bfb7c4..7fc18a6 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -359,6 +359,7 @@ ClockDeleteCmdProc( for (i = 0; i < MCLIT__END; ++i) { Tcl_DecrRefCount(data->mcLitIdxs[i]); } + Tcl_Free(data->mcLitIdxs); data->mcLitIdxs = NULL; } -- cgit v0.12 From b2b727664fc2a795f46b585a2a54412321115e81 Mon Sep 17 00:00:00 2001 From: sebres Date: Sun, 14 Apr 2024 13:32:04 +0000 Subject: revert [0e273ad998f16100], because of bug-fix in tclHash --- generic/tclClockFmt.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclClockFmt.c b/generic/tclClockFmt.c index e63b642..1a506a9 100644 --- a/generic/tclClockFmt.c +++ b/generic/tclClockFmt.c @@ -560,7 +560,6 @@ ClockFmtScnStorageAllocProc( memset(fss, 0, sizeof(*fss)); hPtr = HashEntry4FmtScn(fss); - hPtr->key.oneWordValue = 0; /* See Ticket [167e0635db] */ memcpy(&hPtr->key.string, string, size); hPtr->clientData = 0; /* currently unused */ -- cgit v0.12 From 290472a0a3a1f31ff589eac3d5c9242f7d68bb80 Mon Sep 17 00:00:00 2001 From: sebres Date: Sun, 14 Apr 2024 13:46:23 +0000 Subject: amend to [40f13c108666fdda]: although it is no one free to see after ClockFrmScnFinalize, it is better protected in that way (and also avoid delete hash entry during table deletion). --- generic/tclClockFmt.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclClockFmt.c b/generic/tclClockFmt.c index 1a506a9..156e4d2 100644 --- a/generic/tclClockFmt.c +++ b/generic/tclClockFmt.c @@ -3553,8 +3553,8 @@ ClockFrmScnFinalize( ClockFmtScnStorage_GC.count = 0; #endif if (initialized) { - Tcl_DeleteHashTable(&FmtScnHashTable); initialized = 0; + Tcl_DeleteHashTable(&FmtScnHashTable); } Tcl_MutexUnlock(&ClockFmtMutex); Tcl_MutexFinalize(&ClockFmtMutex); -- cgit v0.12 From c4829502e7b25f121f85f3caaaea837c820ef6d8 Mon Sep 17 00:00:00 2001 From: sebres Date: Sun, 14 Apr 2024 14:41:35 +0000 Subject: free tz.was (in exit handler) --- generic/tclClock.c | 44 +++++++++++++++++++++++++++++++++----------- generic/tclClockFmt.c | 10 +++++----- generic/tclDate.h | 1 + 3 files changed, 39 insertions(+), 16 deletions(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index 7fc18a6..14565ea 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -115,6 +115,7 @@ static struct tm * ThreadSafeLocalTime(const time_t *); static size_t TzsetIfNecessary(void); static void ClockDeleteCmdProc(void *); static Tcl_ObjCmdProc ClockSafeCatchCmd; +static void ClockFinalize(void *); /* * Structure containing description of "native" clock commands to create. */ @@ -180,6 +181,15 @@ TclClockInit( ClockClientData *data; int i; + static int initialized = 0; /* global clock engine initialized (in process) */ + /* + * Register handler to finalize clock on exit. + */ + if (!initialized) { + Tcl_CreateExitHandler(ClockFinalize, NULL); + initialized = 1; + } + /* * Safe interps get [::clock] as alias to a parent, so do not need their * own copies of the support routines. @@ -4640,20 +4650,21 @@ ClockSafeCatchCmd( #endif #define TZ_INIT_MARKER ((WCHAR *) INT2PTR(-1)) +typedef struct ClockTzStatic { + WCHAR *was; /* Previous value of TZ. */ + long long lastRefresh; /* Used for latency before next refresh. */ + size_t epoch; /* Epoch, signals that TZ changed. */ + size_t envEpoch; /* Last env epoch, for faster signaling, + * that TZ changed via TCL */ +} ClockTzStatic; +static ClockTzStatic tz = { /* Global timezone info; protected by + * clockMutex.*/ + TZ_INIT_MARKER, 0, 0, 0 +}; + static size_t TzsetIfNecessary(void) { - typedef struct ClockTzStatic { - WCHAR *was; /* Previous value of TZ. */ - long long lastRefresh; /* Used for latency before next refresh. */ - size_t epoch; /* Epoch, signals that TZ changed. */ - size_t envEpoch; /* Last env epoch, for faster signaling, - * that TZ changed via TCL */ - } ClockTzStatic; - static ClockTzStatic tz = { /* Global timezone info; protected by - * clockMutex.*/ - TZ_INIT_MARKER, 0, 0, 0 - }; const WCHAR *tzNow; /* Current value of TZ. */ Tcl_Time now; /* Current time. */ size_t epoch; /* The tz.epoch that the TZ was read at. */ @@ -4702,6 +4713,17 @@ TzsetIfNecessary(void) return epoch; } +static void +ClockFinalize( + TCL_UNUSED(void *)) +{ + ClockFrmScnFinalize(); + + if (tz.was && tz.was != TZ_INIT_MARKER) { + Tcl_Free(tz.was); + } +} + /* * Local Variables: * mode: c diff --git a/generic/tclClockFmt.c b/generic/tclClockFmt.c index 156e4d2..cd4d39c 100644 --- a/generic/tclClockFmt.c +++ b/generic/tclClockFmt.c @@ -26,7 +26,6 @@ static void ClockFmtObj_UpdateString(Tcl_Obj *objPtr); TCL_DECLARE_MUTEX(ClockFmtMutex); /* Serializes access to common format list. */ static void ClockFmtScnStorageDelete(ClockFmtScnStorage *fss); -static void ClockFrmScnFinalize(void *); /* * Derivation of tclStringHashKeyType with another allocEntryProc @@ -832,7 +831,6 @@ FindOrCreateFmtScnStorage( &ClockFmtScnStorageHashKeyType); initialized = 1; - Tcl_CreateExitHandler(ClockFrmScnFinalize, NULL); } /* get or create entry (and alocate storage) */ @@ -3541,10 +3539,12 @@ ClockFrmScnClearCaches(void) Tcl_MutexUnlock(&ClockFmtMutex); } -static void -ClockFrmScnFinalize( - TCL_UNUSED(void *)) +void +ClockFrmScnFinalize() { + if (!initialized) { + return; + } Tcl_MutexLock(&ClockFmtMutex); #if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0 /* clear GC */ diff --git a/generic/tclDate.h b/generic/tclDate.h index 1657528..fea7cbd 100644 --- a/generic/tclDate.h +++ b/generic/tclDate.h @@ -560,5 +560,6 @@ MODULE_SCOPE int ClockScan(DateInfo *info, Tcl_Obj *strObj, MODULE_SCOPE int ClockFormat(DateFormat *dateFmt, ClockFmtScnCmdArgs *opts); MODULE_SCOPE void ClockFrmScnClearCaches(void); +MODULE_SCOPE void ClockFrmScnFinalize(); #endif /* _TCLCLOCK_H */ -- cgit v0.12 From 3a4af2c98cbdaef1b77ca3e02362b11f6732633a Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 15 Apr 2024 13:21:54 +0000 Subject: clean clock mutex --- generic/tclClock.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tclClock.c b/generic/tclClock.c index 14565ea..817d917 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -4722,6 +4722,8 @@ ClockFinalize( if (tz.was && tz.was != TZ_INIT_MARKER) { Tcl_Free(tz.was); } + + Tcl_MutexFinalize(&clockMutex); } /* -- cgit v0.12 From c328fea7bcbb0f03db0df119e301586847bf3250 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 17 Apr 2024 15:42:12 +0000 Subject: Add pkgs8 directories to git/fossil ignore files --- .fossil-settings/ignore-glob | 2 ++ .gitignore | 2 ++ 2 files changed, 4 insertions(+) diff --git a/.fossil-settings/ignore-glob b/.fossil-settings/ignore-glob index 656e184..1fa4a73 100644 --- a/.fossil-settings/ignore-glob +++ b/.fossil-settings/ignore-glob @@ -60,10 +60,12 @@ unix/tcl.pc unix/tclIndex unix/Tcl-Info.plist unix/Tclsh-Info.plist +unix/pkgs8/* unix/pkgs/* win/Debug* win/Release* win/*.manifest +win/pkgs8/* win/pkgs/* win/coffbase.txt win/tcl.hpj diff --git a/.gitignore b/.gitignore index d55ab1c..ef1bc06 100644 --- a/.gitignore +++ b/.gitignore @@ -56,10 +56,12 @@ unix/dltest.marker unix/dltest/embtest unix/tcl.pc unix/tclIndex +unix/pkgs8/* unix/pkgs/* win/Debug* win/Release* win/*.manifest +win/pkgs8/* win/pkgs/* win/coffbase.txt win/tcl.hpj -- cgit v0.12 From 33fe1e9e5691eb43a528e31b51cab682bd8e2118 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 17 Apr 2024 16:19:32 +0000 Subject: Few additions to release notes --- changes.md | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/changes.md b/changes.md index 415eff7..d9d2d56 100644 --- a/changes.md +++ b/changes.md @@ -70,7 +70,7 @@ Tcl 9: * Internationalization of text - Full Unicode range of codepoints - - New encodings: utf-16(le|be), ucs-2(le|be), CESU-8, etc. + - New encodings: utf-16/utf-32/ucs-2(le|be), CESU-8, etc. - [encoding] options -profile, -failindex manage encoding of I/O. - [msgcat] supports custom locale search list - [source] defaults to -encoding utf-8 @@ -90,6 +90,8 @@ Tcl 9: - $::tcl_precision no longer controls string generation of doubles - Removed Tcl 7 legacies: [case], [puts] [read] variant syntaxes - Removed subcommands [trace variable|vdelete|vinfo] + - No -eofchar option for channels anymore for writing. + - On Windows 10+ (Version 1903 or higher), system encoding is always utf-8. * Incompatibilities in C public interface - Many arguments expanded type from int to Tcl_Size @@ -117,10 +119,12 @@ Tcl 9: - [package files] - [string insert], [string is dict] - [tcl::process] + - [*::build-info] * New command options - [regsub ... -command ...] - [lsearch ... -stride ...] + - [clock scan ... -validate ...] - [socket ... -nodelay ... -keepalive ...] - [vwait] controlled by several new options @@ -153,6 +157,7 @@ Tk 9: - [$frame ... -backgroundimage $img -tile $bool] - [$menu id], [$menu add|insert ... ?$id? ...] - [$image get ... -withalpha ...] + - All indices now accept the forms "end", "end-int", "int+|-int" * Improved widget appearance - ttk::notebook with nondefault tab positions -- cgit v0.12 From 48ccb7e2bc1b9268ec7b910fecaaa255a1845b3d Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 18 Apr 2024 14:41:20 +0000 Subject: Tcl_DuplicateObj can't return NULL --- generic/tclStrIdxTree.c | 52 ++++++++++++++++++++++++++++--------------------- 1 file changed, 30 insertions(+), 22 deletions(-) diff --git a/generic/tclStrIdxTree.c b/generic/tclStrIdxTree.c index 3e02bf0..21be447 100644 --- a/generic/tclStrIdxTree.c +++ b/generic/tclStrIdxTree.c @@ -61,12 +61,12 @@ static void StrIdxTreeObj_FreeIntRepProc(Tcl_Obj *objPtr); static void StrIdxTreeObj_UpdateStringProc(Tcl_Obj *objPtr); static const Tcl_ObjType StrIdxTreeObjType = { - "str-idx-tree", /* name */ - StrIdxTreeObj_FreeIntRepProc, /* freeIntRepProc */ - StrIdxTreeObj_DupIntRepProc, /* dupIntRepProc */ - StrIdxTreeObj_UpdateStringProc, /* updateStringProc */ - NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + "str-idx-tree", /* name */ + StrIdxTreeObj_FreeIntRepProc, /* freeIntRepProc */ + StrIdxTreeObj_DupIntRepProc, /* dupIntRepProc */ + StrIdxTreeObj_UpdateStringProc, /* updateStringProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* @@ -87,14 +87,13 @@ static const Tcl_ObjType StrIdxTreeObjType = { * *---------------------------------------------------------------------- */ - const char * TclStrIdxTreeSearch( - TclStrIdxTree **foundParent, /* Return value of found sub tree (used for tree build) */ - TclStrIdx **foundItem, /* Return value of found item */ - TclStrIdxTree *tree, /* Index tree will be browsed */ - const char *start, /* UTF string to find in tree */ - const char *end) /* End of string */ + TclStrIdxTree **foundParent,/* Return value of found sub tree (used for tree build) */ + TclStrIdx **foundItem, /* Return value of found item */ + TclStrIdxTree *tree, /* Index tree will be browsed */ + const char *start, /* UTF string to find in tree */ + const char *end) /* End of string */ { TclStrIdxTree *parent = tree, *prevParent = tree; TclStrIdx *item = tree->firstPtr, *prevItem = NULL; @@ -116,9 +115,11 @@ TclStrIdxTreeSearch( start = f; goto done; } + /* set new offset and shift start string */ offs += cinf - cin; s = f; + /* if match item, go deeper as long as possible */ if (offs >= item->length && item->childTree.firstPtr) { /* save previuosly found item (if not ambigous) for @@ -132,6 +133,7 @@ TclStrIdxTreeSearch( item = item->childTree.firstPtr; continue; } + /* no children - return this item and current chars found */ start = f; goto done; @@ -176,6 +178,7 @@ TclStrIdxTreeFree( /* * Several bidirectional list primitives */ + static inline void TclStrIdxTreeInsertBranch( TclStrIdxTree *parent, @@ -236,7 +239,6 @@ TclStrIdxTreeAppend( * *---------------------------------------------------------------------- */ - int TclStrIdxTreeBuildFromList( TclStrIdxTree *idxTree, @@ -253,15 +255,12 @@ TclStrIdxTreeBuildFromList( /* create lowercase reflection of the list keys */ - lwrv = (Tcl_Obj **)Tcl_AttemptAlloc(sizeof(Tcl_Obj*) * lstc); + lwrv = (Tcl_Obj **) Tcl_AttemptAlloc(sizeof(Tcl_Obj*) * lstc); if (lwrv == NULL) { return TCL_ERROR; } for (i = 0; i < lstc; i++) { lwrv[i] = Tcl_DuplicateObj(lstv[i]); - if (lwrv[i] == NULL) { - return TCL_ERROR; - } Tcl_IncrRefCount(lwrv[i]); lwrv[i]->length = Tcl_UtfToLower(TclGetString(lwrv[i])); } @@ -283,36 +282,39 @@ TclStrIdxTreeBuildFromList( if (idxTree->firstPtr != NULL) { TclStrIdx *foundItem; - f = TclStrIdxTreeSearch(&foundParent, &foundItem, - idxTree, s, e); + f = TclStrIdxTreeSearch(&foundParent, &foundItem, idxTree, s, e); /* if common prefix was found */ if (f > s) { /* ignore element if fulfilled or ambigous */ if (f == e) { continue; } + /* if shortest key was found with the same value, * just replace its current key with longest key */ if (foundItem->value == val && foundItem->length <= lwrv[i]->length - && foundItem->length <= (f - s) /* only if found item is covered in full */ + && foundItem->length <= (f - s) // only if found item is covered in full && foundItem->childTree.firstPtr == NULL) { TclSetObjRef(foundItem->key, lwrv[i]); foundItem->length = lwrv[i]->length; continue; } + /* split tree (e. g. j->(jan,jun) + jul == j->(jan,ju->(jun,jul)) ) * but don't split by fulfilled child of found item ( ii->iii->iiii ) */ if (foundItem->length != (f - s)) { /* first split found item (insert one between parent and found + new one) */ - item = (TclStrIdx *)Tcl_AttemptAlloc(sizeof(TclStrIdx)); + item = (TclStrIdx *) Tcl_AttemptAlloc(sizeof(TclStrIdx)); if (item == NULL) { goto done; } TclInitObjRef(item->key, foundItem->key); item->length = f - s; + /* set value or mark as ambigous if not the same value of both */ item->value = (foundItem->value == val) ? val : NULL; + /* insert group item between foundParent and foundItem */ TclStrIdxTreeInsertBranch(foundParent, item, foundItem); foundParent = &item->childTree; @@ -322,8 +324,9 @@ TclStrIdxTreeBuildFromList( } } } + /* append item at end of found parent */ - item = (TclStrIdx *)Tcl_AttemptAlloc(sizeof(TclStrIdx)); + item = (TclStrIdx *) Tcl_AttemptAlloc(sizeof(TclStrIdx)); if (item == NULL) { goto done; } @@ -398,6 +401,7 @@ StrIdxTreeObj_DupIntRepProc( { /* follow links (smart pointers) */ srcPtr = FollowPossibleLink(srcPtr); + /* create smart pointer to it (ptr1 != NULL, ptr2 = NULL) */ TclInitObjRef(*((Tcl_Obj **) ©Ptr->internalRep.twoPtrValue.ptr1), srcPtr); @@ -442,8 +446,10 @@ TclStrIdxTreeGetFromObj( if (objPtr->typePtr != &StrIdxTreeObjType) { return NULL; } + /* follow links (smart pointers) */ objPtr = FollowPossibleLink(objPtr); + /* return tree root in internal representation */ return (TclStrIdxTree *) &objPtr->internalRep.twoPtrValue; } @@ -503,6 +509,7 @@ TclStrIdxTreeTestObjCmd( TclGetString(objv[1]), (char *)NULL); return TCL_ERROR; } + switch (optionIndex) { case O_FINDEQUAL: if (objc < 4) { @@ -515,6 +522,7 @@ TclStrIdxTreeTestObjCmd( cs, cs + objv[1]->length, cin, cin + objv[2]->length); Tcl_SetObjResult(interp, Tcl_NewIntObj(ret - cs)); break; + case O_INDEX: case O_PUTS_INDEX: { Tcl_Obj **lstv; -- cgit v0.12 From adc00697fb61715324a8be9401e5d13508215448 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 19 Apr 2024 08:00:18 +0000 Subject: Fix indenting --- generic/tclIO.c | 5 +- generic/tclIORChan.c | 286 +++++++++++++++++++++++++-------------------------- 2 files changed, 145 insertions(+), 146 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 6dbf5d9..44d4f7d 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3152,8 +3152,8 @@ CloseChannel( /* * Cancel any outstanding timer. */ - DeleteTimerHandler(statePtr); + DeleteTimerHandler(statePtr); /* * Mark the channel as deleted by clearing the type structure. @@ -7544,7 +7544,6 @@ Tcl_Eof( return GotFlag(statePtr, CHANNEL_EOF) ? 1 : 0; } - /* *---------------------------------------------------------------------- * @@ -7570,7 +7569,7 @@ TclChannelGetBlockingMode( return GotFlag(statePtr, CHANNEL_NONBLOCKING) ? 0 : 1; } - + /* *---------------------------------------------------------------------- * diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 5417730..fe54f65 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -78,7 +78,7 @@ static const Tcl_ChannelType tclRChannelType = { NULL, /* Handle events. NULL'able */ ReflectSeekWide, /* Move access point (64 bit). NULL'able */ #if TCL_THREADS - ReflectThread, /* thread action, tracking owner */ + ReflectThread, /* thread action, tracking owner */ #else NULL, /* thread action */ #endif @@ -100,7 +100,7 @@ typedef struct { */ #if TCL_THREADS Tcl_ThreadId thread; /* Thread the 'interp' belongs to. == Handler thread */ - Tcl_ThreadId owner; /* Thread owning the structure. == Channel thread */ + Tcl_ThreadId owner; /* Thread owning the structure. == Channel thread */ #endif Tcl_Obj *cmd; /* Callback command prefix */ Tcl_Obj *methods; /* Methods to append to command prefix */ @@ -117,12 +117,12 @@ typedef struct { A token for the timer that is scheduled in order to call Tcl_NotifyChannel when the channel is readable - */ + */ Tcl_TimerToken writeTimer; /* A token for the timer that is scheduled in order to call Tcl_NotifyChannel when the channel is writable - */ + */ /* * Note regarding the usage of timers. @@ -613,9 +613,9 @@ TclChanCreateObjCmd( */ if (TclListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "chan handler \"%s initialize\" returned non-list: %s", - TclGetString(cmdObj), TclGetString(resObj))); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s initialize\" returned non-list: %s", + TclGetString(cmdObj), TclGetString(resObj))); Tcl_DecrRefCount(resObj); goto error; } @@ -639,37 +639,37 @@ TclChanCreateObjCmd( Tcl_DecrRefCount(resObj); if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "chan handler \"%s\" does not support all required methods", - TclGetString(cmdObj))); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" does not support all required methods", + TclGetString(cmdObj))); goto error; } if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "chan handler \"%s\" lacks a \"read\" method", - TclGetString(cmdObj))); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" lacks a \"read\" method", + TclGetString(cmdObj))); goto error; } if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "chan handler \"%s\" lacks a \"write\" method", - TclGetString(cmdObj))); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" lacks a \"write\" method", + TclGetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_CGET), HAS(methods, METH_CGETALL))) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "chan handler \"%s\" supports \"cget\" but not \"cgetall\"", - TclGetString(cmdObj))); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" supports \"cget\" but not \"cgetall\"", + TclGetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_CGETALL), HAS(methods, METH_CGET))) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "chan handler \"%s\" supports \"cgetall\" but not \"cget\"", - TclGetString(cmdObj))); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" supports \"cgetall\" but not \"cget\"", + TclGetString(cmdObj))); goto error; } @@ -742,7 +742,7 @@ TclChanCreateObjCmd( */ Tcl_SetObjResult(interp, - Tcl_NewStringObj(chanPtr->state->channelName, -1)); + Tcl_NewStringObj(chanPtr->state->channelName, -1)); return TCL_OK; error: @@ -814,7 +814,7 @@ ReflectEventDelete( ReflectEvent *e = (ReflectEvent *) ev; if ((ev->proc != ReflectEventRun) || ((cd != NULL) && (cd != e->rcPtr))) { - return 0; + return 0; } return 1; } @@ -873,7 +873,7 @@ TclChanPostEventObjCmd( if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can not find reflected channel named \"%s\"", chanId)); + "can not find reflected channel named \"%s\"", chanId)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanId, (char *)NULL); return TCL_ERROR; } @@ -937,8 +937,8 @@ TclChanPostEventObjCmd( if (events & ~rcPtr->interest) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "tried to post events channel \"%s\" is not interested in", - chanId)); + "tried to post events channel \"%s\" is not interested in", + chanId)); return TCL_ERROR; } @@ -963,36 +963,36 @@ TclChanPostEventObjCmd( } #if TCL_THREADS } else { - ReflectEvent *ev = (ReflectEvent *)Tcl_Alloc(sizeof(ReflectEvent)); - - ev->header.proc = ReflectEventRun; - ev->events = events; - ev->rcPtr = rcPtr; - - /* - * We are not preserving the structure here. When the channel is - * closed any pending events are deleted, see ReflectClose(), and - * ReflectEventDelete(). Trying to preserve and later release when the - * event is run may generate a situation where the channel structure - * is deleted but not our structure, crashing in - * FreeReflectedChannel(). - * - * Force creation of the RCM, for proper cleanup on thread teardown. - * The teardown of unprocessed events is currently coupled to the - * thread reflected channel map - */ - - (void) GetThreadReflectedChannelMap(); - - /* - * XXX Race condition !! - * XXX The destination thread may not exist anymore already. - * XXX (Delayed postevent executed after channel got removed). - * XXX Can we detect this ? (check the validity of the owner threadid ?) - * XXX Actually, in that case the channel should be dead also ! - */ - - Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev, + ReflectEvent *ev = (ReflectEvent *)Tcl_Alloc(sizeof(ReflectEvent)); + + ev->header.proc = ReflectEventRun; + ev->events = events; + ev->rcPtr = rcPtr; + + /* + * We are not preserving the structure here. When the channel is + * closed any pending events are deleted, see ReflectClose(), and + * ReflectEventDelete(). Trying to preserve and later release when the + * event is run may generate a situation where the channel structure + * is deleted but not our structure, crashing in + * FreeReflectedChannel(). + * + * Force creation of the RCM, for proper cleanup on thread teardown. + * The teardown of unprocessed events is currently coupled to the + * thread reflected channel map + */ + + (void) GetThreadReflectedChannelMap(); + + /* + * XXX Race condition !! + * XXX The destination thread may not exist anymore already. + * XXX (Delayed postevent executed after channel got removed). + * XXX Can we detect this ? (check the validity of the owner threadid ?) + * XXX Actually, in that case the channel should be dead also ! + */ + + Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev, TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY); } #endif @@ -1207,11 +1207,11 @@ ReflectClose( ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p); result = p.base.code; - /* - * Now squash the pending reflection events for this channel. - */ + /* + * Now squash the pending reflection events for this channel. + */ - Tcl_DeleteEvents(ReflectEventDelete, rcPtr); + Tcl_DeleteEvents(ReflectEventDelete, rcPtr); if (result != TCL_OK) { FreeReceivedError(&p); @@ -1245,11 +1245,11 @@ ReflectClose( ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p); result = p.base.code; - /* - * Now squash the pending reflection events for this channel. - */ + /* + * Now squash the pending reflection events for this channel. + */ - Tcl_DeleteEvents(ReflectEventDelete, rcPtr); + Tcl_DeleteEvents(ReflectEventDelete, rcPtr); if (result != TCL_OK) { PassReceivedErrorInterp(interp, &p); @@ -1384,11 +1384,11 @@ ReflectInput( if (code < 0) { *errorCodePtr = -code; - goto error; + goto error; } Tcl_SetChannelError(rcPtr->chan, resObj); - goto invalid; + goto invalid; } bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); @@ -1468,9 +1468,9 @@ ReflectOutput( *errorCodePtr = -p.base.code; } else { - PassReceivedError(rcPtr->chan, &p); - *errorCodePtr = EINVAL; - } + PassReceivedError(rcPtr->chan, &p); + *errorCodePtr = EINVAL; + } p.output.toWrite = -1; } else { *errorCodePtr = EOK; @@ -1494,11 +1494,11 @@ ReflectOutput( if (code < 0) { *errorCodePtr = -code; - goto error; + goto error; } Tcl_SetChannelError(rcPtr->chan, resObj); - goto invalid; + goto invalid; } if (Tcl_InterpDeleted(rcPtr->interp)) { @@ -1507,11 +1507,11 @@ ReflectOutput( */ SetChannelErrorStr(rcPtr->chan, msg_send_dstlost); - goto invalid; + goto invalid; } if (Tcl_GetIntFromObj(rcPtr->interp, resObj, &written) != TCL_OK) { Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp)); - goto invalid; + goto invalid; } if ((written == 0) && (toWrite > 0)) { @@ -1521,7 +1521,7 @@ ReflectOutput( */ SetChannelErrorStr(rcPtr->chan, msg_write_nothing); - goto invalid; + goto invalid; } if (toWrite < written) { /* @@ -1531,7 +1531,7 @@ ReflectOutput( */ SetChannelErrorStr(rcPtr->chan, msg_write_toomuch); - goto invalid; + goto invalid; } *errorCodePtr = EOK; @@ -1607,24 +1607,24 @@ ReflectSeekWide( TclNewIntObj(offObj, offset); baseObj = Tcl_NewStringObj( - (seekMode == SEEK_SET) ? "start" : - (seekMode == SEEK_CUR) ? "current" : "end", -1); + (seekMode == SEEK_SET) ? "start" : + (seekMode == SEEK_CUR) ? "current" : "end", -1); Tcl_IncrRefCount(offObj); Tcl_IncrRefCount(baseObj); if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK) { Tcl_SetChannelError(rcPtr->chan, resObj); - goto invalid; + goto invalid; } if (TclGetWideIntFromObj(rcPtr->interp, resObj, &newLoc) != TCL_OK) { Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp)); - goto invalid; + goto invalid; } if (newLoc < 0) { SetChannelErrorStr(rcPtr->chan, msg_seek_beforestart); - goto invalid; + goto invalid; } *errorCodePtr = EOK; @@ -1805,14 +1805,14 @@ ReflectThread( switch (action) { case TCL_CHANNEL_THREAD_INSERT: - rcPtr->owner = Tcl_GetCurrentThread(); - break; + rcPtr->owner = Tcl_GetCurrentThread(); + break; case TCL_CHANNEL_THREAD_REMOVE: - rcPtr->owner = NULL; - break; + rcPtr->owner = NULL; + break; default: - Tcl_Panic("Unknown thread action code."); - break; + Tcl_Panic("Unknown thread action code."); + break; } } @@ -1971,14 +1971,14 @@ ReflectGetOption( method = METH_CGET; optionObj = Tcl_NewStringObj(optionName, -1); - Tcl_IncrRefCount(optionObj); + Tcl_IncrRefCount(optionObj); } Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, method, optionObj, NULL, &resObj)!=TCL_OK) { UnmarshallErrorResult(interp, resObj); - goto error; + goto error; } /* @@ -1988,7 +1988,7 @@ ReflectGetOption( if (optionObj != NULL) { TclDStringAppendObj(dsPtr, resObj); - goto ok; + goto ok; } /* @@ -2003,7 +2003,7 @@ ReflectGetOption( */ if (TclListObjGetElements(interp, resObj, &listc, &listv) != TCL_OK) { - goto error; + goto error; } if ((listc % 2) == 1) { @@ -2016,7 +2016,7 @@ ReflectGetOption( "Expected list with even number of " "elements, got %" TCL_SIZE_MODIFIER "d element%s instead", listc, (listc == 1 ? "" : "s"))); - goto error; + goto error; } else { Tcl_Size len; const char *str = TclGetStringFromObj(resObj, &len); @@ -2025,14 +2025,14 @@ ReflectGetOption( TclDStringAppendLiteral(dsPtr, " "); Tcl_DStringAppend(dsPtr, str, len); } - goto ok; + goto ok; } ok: result = TCL_OK; stop: if (optionObj) { - Tcl_DecrRefCount(optionObj); + Tcl_DecrRefCount(optionObj); } Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ Tcl_Release(rcPtr); @@ -2386,10 +2386,10 @@ InvokeTclMethod( Tcl_IncrRefCount(resObj); } - /* - * Not touching argOneObj, argTwoObj, they have not been used. - * See the contract as well. - */ + /* + * Not touching argOneObj, argTwoObj, they have not been used. + * See the contract as well. + */ return TCL_ERROR; } @@ -2685,11 +2685,11 @@ DeleteReflectedChannelMap( /* * The receiver for the event exited, before processing the event. We * detach the result now, wake the originator up and signal failure. - * - * Attention: Results may have been detached already, by either the - * receiver, or this thread, as part of other parts in the thread - * teardown. Such results are ignored. See ticket [b47b176adf] for the - * identical race condition in Tcl 8.6 IORTrans. + * + * Attention: Results may have been detached already, by either the + * receiver, or this thread, as part of other parts in the thread + * teardown. Such results are ignored. See ticket [b47b176adf] for the + * identical race condition in Tcl 8.6 IORTrans. */ evPtr = resultPtr->evPtr; @@ -2838,11 +2838,11 @@ DeleteThreadReflectedChannelMap( /* * The receiver for the event exited, before processing the event. We * detach the result now, wake the originator up and signal failure. - * - * Attention: Results may have been detached already, by either the - * receiver, or this thread, as part of other parts in the thread - * teardown. Such results are ignored. See ticket [b47b176adf] for the - * identical race condition in Tcl 8.6 IORTrans. + * + * Attention: Results may have been detached already, by either the + * receiver, or this thread, as part of other parts in the thread + * teardown. Such results are ignored. See ticket [b47b176adf] for the + * identical race condition in Tcl 8.6 IORTrans. */ evPtr = resultPtr->evPtr; @@ -3051,7 +3051,7 @@ ForwardProc( ForwardParam *paramPtr = evPtr->param; Tcl_Obj *resObj = NULL; /* Interp result of InvokeTclMethod */ ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in - * this interp. */ + * this interp. */ Tcl_HashEntry *hPtr; /* Entry in the above map */ /* @@ -3094,12 +3094,12 @@ ForwardProc( rcmPtr = GetReflectedChannelMap(interp); hPtr = Tcl_FindHashEntry(&rcmPtr->map, - Tcl_GetChannelName(rcPtr->chan)); + Tcl_GetChannelName(rcPtr->chan)); Tcl_DeleteHashEntry(hPtr); rcmPtr = GetThreadReflectedChannelMap(); hPtr = Tcl_FindHashEntry(&rcmPtr->map, - Tcl_GetChannelName(rcPtr->chan)); + Tcl_GetChannelName(rcPtr->chan)); Tcl_DeleteHashEntry(hPtr); MarkDead(rcPtr); break; @@ -3144,17 +3144,17 @@ ForwardProc( paramPtr->input.toRead = bytec; } } - Tcl_Release(rcPtr); - Tcl_DecrRefCount(toReadObj); + Tcl_Release(rcPtr); + Tcl_DecrRefCount(toReadObj); break; } case ForwardedOutput: { Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *) - paramPtr->output.buf, paramPtr->output.toWrite); - Tcl_IncrRefCount(bufObj); + paramPtr->output.buf, paramPtr->output.toWrite); + Tcl_IncrRefCount(bufObj); - Tcl_Preserve(rcPtr); + Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, METH_WRITE, bufObj, NULL, &resObj) != TCL_OK) { int code = ErrnoReturn(rcPtr, resObj); @@ -3183,8 +3183,8 @@ ForwardProc( paramPtr->output.toWrite = written; } } - Tcl_Release(rcPtr); - Tcl_DecrRefCount(bufObj); + Tcl_Release(rcPtr); + Tcl_DecrRefCount(bufObj); break; } @@ -3226,35 +3226,35 @@ ForwardProc( paramPtr->seek.offset = -1; } } - Tcl_Release(rcPtr); - Tcl_DecrRefCount(offObj); - Tcl_DecrRefCount(baseObj); + Tcl_Release(rcPtr); + Tcl_DecrRefCount(offObj); + Tcl_DecrRefCount(baseObj); break; } case ForwardedWatch: { Tcl_Obj *maskObj = DecodeEventMask(paramPtr->watch.mask); - /* assert maskObj.refCount == 1 */ + /* assert maskObj.refCount == 1 */ - Tcl_Preserve(rcPtr); + Tcl_Preserve(rcPtr); rcPtr->interest = paramPtr->watch.mask; (void) InvokeTclMethod(rcPtr, METH_WATCH, maskObj, NULL, NULL); Tcl_DecrRefCount(maskObj); - Tcl_Release(rcPtr); + Tcl_Release(rcPtr); break; } case ForwardedBlock: { Tcl_Obj *blockObj = Tcl_NewBooleanObj(!paramPtr->block.nonblocking); - Tcl_IncrRefCount(blockObj); - Tcl_Preserve(rcPtr); + Tcl_IncrRefCount(blockObj); + Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, METH_BLOCKING, blockObj, NULL, - &resObj) != TCL_OK) { + &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); } - Tcl_Release(rcPtr); - Tcl_DecrRefCount(blockObj); + Tcl_Release(rcPtr); + Tcl_DecrRefCount(blockObj); break; } @@ -3262,16 +3262,16 @@ ForwardProc( Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->setOpt.name, -1); Tcl_Obj *valueObj = Tcl_NewStringObj(paramPtr->setOpt.value, -1); - Tcl_IncrRefCount(optionObj); - Tcl_IncrRefCount(valueObj); - Tcl_Preserve(rcPtr); + Tcl_IncrRefCount(optionObj); + Tcl_IncrRefCount(valueObj); + Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, METH_CONFIGURE, optionObj, valueObj, - &resObj) != TCL_OK) { + &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); } - Tcl_Release(rcPtr); - Tcl_DecrRefCount(optionObj); - Tcl_DecrRefCount(valueObj); + Tcl_Release(rcPtr); + Tcl_DecrRefCount(optionObj); + Tcl_DecrRefCount(valueObj); break; } @@ -3282,15 +3282,15 @@ ForwardProc( Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->getOpt.name, -1); - Tcl_IncrRefCount(optionObj); - Tcl_Preserve(rcPtr); + Tcl_IncrRefCount(optionObj); + Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, METH_CGET, optionObj, NULL, &resObj)!=TCL_OK){ ForwardSetObjError(paramPtr, resObj); } else { TclDStringAppendObj(paramPtr->getOpt.value, resObj); } - Tcl_Release(rcPtr); - Tcl_DecrRefCount(optionObj); + Tcl_Release(rcPtr); + Tcl_DecrRefCount(optionObj); break; } @@ -3299,7 +3299,7 @@ ForwardProc( * Retrieve all options. */ - Tcl_Preserve(rcPtr); + Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, METH_CGETALL, NULL, NULL, &resObj) != TCL_OK){ ForwardSetObjError(paramPtr, resObj); } else { @@ -3312,7 +3312,7 @@ ForwardProc( Tcl_Obj **listv; if (TclListObjGetElements(interp, resObj, &listc, - &listv) != TCL_OK) { + &listv) != TCL_OK) { Tcl_DecrRefCount(resObj); resObj = MarshallError(interp); ForwardSetObjError(paramPtr, resObj); @@ -3337,7 +3337,7 @@ ForwardProc( } } } - Tcl_Release(rcPtr); + Tcl_Release(rcPtr); break; case ForwardedTruncate: { -- cgit v0.12 From 8b5f712b6628bde4df926a2d11618c7f7bd7d7fe Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 23 Apr 2024 20:11:45 +0000 Subject: Possible fix for [ef23a85ac6]: Tcl_PanicProc - Tcl9 & NaviServer --- generic/tcl.decls | 4 ++-- generic/tcl.h | 6 +++--- generic/tclEvent.c | 4 ++-- generic/tclPanic.c | 4 ++-- 4 files changed, 9 insertions(+), 9 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 41fe5f3..20b6cba 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2417,10 +2417,10 @@ export { Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc) } export { - const char *Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) + const char *Tcl_SetPanicProc(Tcl_PanicProc *panicProc) } export { - Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc) + Tcl_ExitProc *Tcl_SetExitProc(Tcl_ExitProc *proc) } export { const char *Tcl_FindExecutable(const char *argv0) diff --git a/generic/tcl.h b/generic/tcl.h index d339b8f..774ac18 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -597,7 +597,7 @@ typedef void (Tcl_FreeProc) (char *blockPtr); #endif typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp); typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags); -typedef void (Tcl_PanicProc) (const char *format, ...); +typedef TCL_NORETURN1 void (Tcl_PanicProc) (const char *format, ...); typedef void (Tcl_TcpAcceptProc) (void *callbackData, Tcl_Channel chan, char *address, int port); typedef void (Tcl_TimerProc) (void *clientData); @@ -2371,7 +2371,7 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); EXTERN const char * Tcl_FindExecutable(const char *argv0); EXTERN const char * Tcl_SetPreInitScript(const char *string); EXTERN const char * Tcl_SetPanicProc( - TCL_NORETURN1 Tcl_PanicProc *panicProc); + Tcl_PanicProc *panicProc); EXTERN void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, @@ -2379,7 +2379,7 @@ EXTERN void Tcl_StaticLibrary(Tcl_Interp *interp, #ifndef TCL_NO_DEPRECATED # define Tcl_StaticPackage Tcl_StaticLibrary #endif -EXTERN Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc); +EXTERN Tcl_ExitProc *Tcl_SetExitProc(Tcl_ExitProc *proc); #ifdef _WIN32 EXTERN const char *TclZipfs_AppHook(int *argc, wchar_t ***argv); #else diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 69c3c27..ad0f820 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -105,7 +105,7 @@ static const char ENCODING_ERROR[] = "\n\t(encoding error in stderr)"; * non-NULL value. */ -static TCL_NORETURN1 Tcl_ExitProc *appExitPtr = NULL; +static Tcl_ExitProc *appExitPtr = NULL; typedef struct ThreadSpecificData { ExitHandler *firstExitPtr; /* First in list of all exit handlers for this @@ -958,7 +958,7 @@ Tcl_Exit( int status) /* Exit status for application; typically 0 * for normal return, 1 for error return. */ { - TCL_NORETURN1 Tcl_ExitProc *currentAppExitPtr; + Tcl_ExitProc *currentAppExitPtr; Tcl_MutexLock(&exitMutex); currentAppExitPtr = appExitPtr; diff --git a/generic/tclPanic.c b/generic/tclPanic.c index 5a05c24..2dd33d2 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -23,7 +23,7 @@ * procedure. */ -static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL; +static Tcl_PanicProc *panicProc = NULL; /* *---------------------------------------------------------------------- @@ -43,7 +43,7 @@ static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL; const char * Tcl_SetPanicProc( - TCL_NORETURN1 Tcl_PanicProc *proc) + Tcl_PanicProc *proc) { panicProc = proc; return Tcl_InitSubsystems(); -- cgit v0.12 From cf03773499c65e0d3f41f9b73991911bbe76d358 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 23 Apr 2024 20:17:26 +0000 Subject: Still one TCL_NORETURN1 too much --- generic/tclEvent.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index ad0f820..49467c8 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -877,7 +877,7 @@ Tcl_DeleteThreadExitHandler( Tcl_ExitProc * Tcl_SetExitProc( - TCL_NORETURN1 Tcl_ExitProc *proc) /* New exit handler for app or NULL */ + Tcl_ExitProc *proc) /* New exit handler for app or NULL */ { Tcl_ExitProc *prevExitProc; -- cgit v0.12 From 5a5cfe0be03b5d889080d9a701f89107a70d7a29 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 23 Apr 2024 20:36:04 +0000 Subject: Missing "_" in __declspec --- generic/tcl.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tcl.h b/generic/tcl.h index 774ac18..90bc0c1 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -117,7 +117,7 @@ extern "C" { #else # define TCL_FORMAT_PRINTF(a,b) # if defined(_MSC_VER) -# define TCL_NORETURN _declspec(noreturn) +# define TCL_NORETURN __declspec(noreturn) # define TCL_NOINLINE __declspec(noinline) # else # define TCL_NORETURN /* nothing */ -- cgit v0.12 From 69ed03bc06bf1afd409d4cc9e4f0b9895474acfa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 24 Apr 2024 19:16:12 +0000 Subject: Improve use of TCL_NORETURN, so no unnecessary warnings are produced any more --- generic/tcl.h | 4 ++-- generic/tclPanic.c | 26 +++++++++++++------------- win/tclWinPanic.c | 16 +--------------- 3 files changed, 16 insertions(+), 30 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 90bc0c1..52288ab 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -597,7 +597,7 @@ typedef void (Tcl_FreeProc) (char *blockPtr); #endif typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp); typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags); -typedef TCL_NORETURN1 void (Tcl_PanicProc) (const char *format, ...); +typedef void (Tcl_PanicProc) (const char *format, ...); typedef void (Tcl_TcpAcceptProc) (void *callbackData, Tcl_Channel chan, char *address, int port); typedef void (Tcl_TimerProc) (void *clientData); @@ -2312,7 +2312,7 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp, const char * TclInitStubTable(const char *version); void * TclStubCall(void *arg); #if defined(_WIN32) - TCL_NORETURN1 void Tcl_ConsolePanic(const char *format, ...); + void Tcl_ConsolePanic(const char *format, ...); #else # define Tcl_ConsolePanic NULL #endif diff --git a/generic/tclPanic.c b/generic/tclPanic.c index 2dd33d2..dcceb25 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -71,7 +71,7 @@ Tcl_SetPanicProc( */ /* coverity[+kill] */ -void +TCL_NORETURN void Tcl_Panic( const char *format, ...) @@ -104,21 +104,21 @@ Tcl_Panic( fprintf(stderr, "\n"); fflush(stderr); #endif -# if defined(__GNUC__) - __builtin_trap(); -# elif defined(_WIN64) - __debugbreak(); -# elif defined(_MSC_VER) && defined (_M_IX86) - _asm {int 3} -# elif defined(_WIN32) - DebugBreak(); -# endif + } +#if defined(__GNUC__) + __builtin_trap(); +#elif defined(_WIN64) + __debugbreak(); +#elif defined(_MSC_VER) && defined (_M_IX86) + _asm {int 3} +#elif defined(_WIN32) + DebugBreak(); +#endif #if defined(_WIN32) - ExitProcess(1); + ExitProcess(1); #else - abort(); + abort(); #endif - } } /* diff --git a/win/tclWinPanic.c b/win/tclWinPanic.c index 7928dcd..02bd767 100644 --- a/win/tclWinPanic.c +++ b/win/tclWinPanic.c @@ -28,7 +28,7 @@ *---------------------------------------------------------------------- */ -TCL_NORETURN1 void +void Tcl_ConsolePanic( const char *format, ...) { @@ -63,20 +63,6 @@ Tcl_ConsolePanic( WriteFile(handle, "\n", 1, &dummy, 0); FlushFileBuffers(handle); } -# if defined(__GNUC__) - __builtin_trap(); -# elif defined(_WIN64) - __debugbreak(); -# elif defined(_MSC_VER) - _asm {int 3} -# else - DebugBreak(); -# endif -#if defined(_WIN32) - ExitProcess(1); -#else - abort(); -#endif } /* * Local Variables: -- cgit v0.12 From 1abff90ead8c13fee3de05eb1f7bb31cde01a159 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 24 Apr 2024 19:41:08 +0000 Subject: Better keep Tcl_ConsolePanic as it was (with TCL_NORETURN) --- generic/tcl.h | 2 +- win/tclWinPanic.c | 16 +++++++++++++++- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 52288ab..d5951c4 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2312,7 +2312,7 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp, const char * TclInitStubTable(const char *version); void * TclStubCall(void *arg); #if defined(_WIN32) - void Tcl_ConsolePanic(const char *format, ...); + TCL_NORETURN void Tcl_ConsolePanic(const char *format, ...); #else # define Tcl_ConsolePanic NULL #endif diff --git a/win/tclWinPanic.c b/win/tclWinPanic.c index 02bd767..65527f7 100644 --- a/win/tclWinPanic.c +++ b/win/tclWinPanic.c @@ -28,7 +28,7 @@ *---------------------------------------------------------------------- */ -void +TCL_NORETURN void Tcl_ConsolePanic( const char *format, ...) { @@ -63,6 +63,20 @@ Tcl_ConsolePanic( WriteFile(handle, "\n", 1, &dummy, 0); FlushFileBuffers(handle); } +# if defined(__GNUC__) + __builtin_trap(); +# elif defined(_WIN64) + __debugbreak(); +# elif defined(_MSC_VER) + _asm {int 3} +# else + DebugBreak(); +# endif +#if defined(_WIN32) + ExitProcess(1); +#else + abort(); +#endif } /* * Local Variables: -- cgit v0.12 From 050612f80d48c8a4a0b8c303eb21eb9a73a23ce6 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 25 Apr 2024 04:47:13 +0000 Subject: Fix building of libtclzip for out-of-source builds --- win/makefile.vc | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/win/makefile.vc b/win/makefile.vc index 152fc1e..13b5396 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -464,7 +464,8 @@ TCLSTUBOBJS = \ TOMMATHDIR = $(ROOT)\libtommath PKGSDIR = $(ROOT)\pkgs -LIBTCLVFS = $(OUT_DIR)\libtcl.vfs +LIBTCLVFSSUBDIR = libtcl.vfs +LIBTCLVFS = $(OUT_DIR)\$(LIBTCLVFSSUBDIR) # Additional include and C macro definitions for the implicit rules # defined in rules.vc @@ -664,9 +665,10 @@ $(TCLSCRIPTZIP): $(TCLLIB) $(TCLSH) dlls @$(COPY) $(TCLDDELIB) "$(LIBTCLVFS)\tcl_library\dde @$(COPY) $(TCLREGLIB) "$(LIBTCLVFS)\tcl_library\registry !endif - @echo file delete -force {$@} > "$(OUT_DIR)\zipper.tcl" - @echo zipfs mkzip {$@} {$(LIBTCLVFS)} {$(LIBTCLVFS)} >> "$(OUT_DIR)\zipper.tcl" - @cd "$(OUT_DIR)" && $(TCLSH_NATIVE) zipper.tcl + @echo cd {$(OUT_DIR)} > "$(OUT_DIR)\zipper.tcl" + @echo file delete -force {$(@F)} >> "$(OUT_DIR)\zipper.tcl" + @echo zipfs mkzip {$(@F)} {$(LIBTCLVFSSUBDIR)} {$(LIBTCLVFSSUBDIR)} >> "$(OUT_DIR)\zipper.tcl" + @$(TCLSH_NATIVE) "$(OUT_DIR)/zipper.tcl" pkgs: @for /d %d in ($(PKGSDIR)\*) do \ -- cgit v0.12