From 7c54b6f6fd2a99998ce0daa0b32c8940d1ed5eea Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Oct 2019 10:53:58 +0000 Subject: tclAppInit.c should be built without BUILD_tcl/USE_TCL_STUBS always. All build files should be adapted now to assure that. --- generic/tclDecls.h | 9 --------- unix/tclAppInit.c | 11 ++++++----- win/tclAppInit.c | 7 +++++-- 3 files changed, 11 insertions(+), 16 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index b37491a..6ab227f 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3931,19 +3931,10 @@ extern const TclStubs *tclStubsPtr; /* !END!: Do not edit above this line. */ #if defined(USE_TCL_STUBS) -# undef Tcl_CreateInterp # undef Tcl_FindExecutable -# undef Tcl_GetStringResult -# undef Tcl_Init # undef Tcl_SetPanicProc # undef Tcl_SetExitProc -# undef Tcl_ObjSetVar2 # undef Tcl_StaticPackage -# define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) -# define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp)) -# define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp)) -# define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \ - (tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags)) #endif #if defined(_WIN32) && defined(UNICODE) diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 3587f35..aa060ab 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -12,8 +12,9 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#undef BUILD_tcl -#undef STATIC_BUILD +#if defined(BUILD_tcl) || defined(USE_TCL_STUBS) +#error "Don't build with BUILD_tcl/USE_TCL_STUBS!" +#endif #include "tcl.h" #ifdef TCL_TEST @@ -110,7 +111,7 @@ int Tcl_AppInit( Tcl_Interp *interp) /* Interpreter for application. */ { - if ((Tcl_Init)(interp) == TCL_ERROR) { + if (Tcl_Init(interp) == TCL_ERROR) { return TCL_ERROR; } @@ -152,10 +153,10 @@ Tcl_AppInit( */ #ifdef DJGPP - (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, + Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, Tcl_NewStringObj("~/tclsh.rc", -1), TCL_GLOBAL_ONLY); #else - (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, + Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, Tcl_NewStringObj("~/.tclshrc", -1), TCL_GLOBAL_ONLY); #endif diff --git a/win/tclAppInit.c b/win/tclAppInit.c index fa27756..348b32c 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -14,6 +14,9 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#if defined(BUILD_tcl) || defined(USE_TCL_STUBS) +#error "Don't build with BUILD_tcl/USE_TCL_STUBS!" +#endif #include "tcl.h" #define WIN32_LEAN_AND_MEAN #define STRICT /* See MSDN Article Q83456 */ @@ -158,7 +161,7 @@ int Tcl_AppInit( Tcl_Interp *interp) /* Interpreter for application. */ { - if ((Tcl_Init)(interp) == TCL_ERROR) { + if (Tcl_Init(interp) == TCL_ERROR) { return TCL_ERROR; } @@ -205,7 +208,7 @@ Tcl_AppInit( * user-specific startup file will be run under any conditions. */ - (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, + Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, Tcl_NewStringObj("~/tclshrc.tcl", -1), TCL_GLOBAL_ONLY); return TCL_OK; } -- cgit v0.12 From 474c08922f5e9eb3699fba6cf236e4fde61ae390 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Jun 2022 15:12:27 +0000 Subject: (experimental) TclOO > 2**31 args --- generic/tclExecute.c | 6 ++++- generic/tclOO.decls | 14 +++++++++++ generic/tclOO.h | 23 +++++++++++++++++- generic/tclOOCall.c | 6 ++++- generic/tclOODecls.h | 23 ++++++++++++++++++ generic/tclOOMethod.c | 63 +++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclOOStubInit.c | 3 +++ 7 files changed, 135 insertions(+), 3 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2b197c6..fe809c1 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4787,7 +4787,11 @@ TEBCresume( Method *const mPtr = contextPtr->callPtr->chain[newDepth].mPtr; - return mPtr->typePtr->callProc(mPtr->clientData, interp, + if (mPtr->typePtr->version == TCL_OO_METHOD_VERSION_1) { + return mPtr->typePtr->callProc(mPtr->clientData, interp, + (Tcl_ObjectContext) contextPtr, opnd, objv); + } + return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp, (Tcl_ObjectContext) contextPtr, opnd, objv); } diff --git a/generic/tclOO.decls b/generic/tclOO.decls index e4063c7..3507c73 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -135,6 +135,20 @@ declare 30 { declare 31 { Tcl_Obj *Tcl_GetObjectClassName(Tcl_Interp *interp, Tcl_Object object) } +declare 32 { + int Tcl_MethodIsType2(Tcl_Method method, const Tcl_MethodType2 *typePtr, + void **clientDataPtr) +} +declare 33 { + Tcl_Method Tcl_NewInstanceMethod2(Tcl_Interp *interp, Tcl_Object object, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, + void *clientData) +} +declare 34 { + Tcl_Method Tcl_NewMethod2(Tcl_Interp *interp, Tcl_Class cls, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, + void *clientData) +} ###################################################################### # Private API, exposed to support advanced OO systems that plug in on top of diff --git a/generic/tclOO.h b/generic/tclOO.h index 9c1dd1e..0ddb13c 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -62,6 +62,8 @@ typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext; typedef int (Tcl_MethodCallProc)(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv); +typedef int (Tcl_MethodCallProc2)(ClientData clientData, Tcl_Interp *interp, + Tcl_ObjectContext objectContext, size_t objc, Tcl_Obj *const *objv); typedef void (Tcl_MethodDeleteProc)(ClientData clientData); typedef int (Tcl_CloneProc)(Tcl_Interp *interp, ClientData oldClientData, ClientData *newClientData); @@ -77,7 +79,7 @@ typedef int (Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp, typedef struct { int version; /* Structure version field. Always to be equal - * to TCL_OO_METHOD_VERSION_CURRENT in + * to TCL_OO_METHOD_VERSION_(1|CURRENT) in * declarations. */ const char *name; /* Name of this type of method, mostly for * debugging purposes. */ @@ -92,12 +94,31 @@ typedef struct { * be copied directly. */ } Tcl_MethodType; +typedef struct { + int version; /* Structure version field. Always to be equal + * to TCL_OO_METHOD_VERSION_2 in + * declarations. */ + const char *name; /* Name of this type of method, mostly for + * debugging purposes. */ + Tcl_MethodCallProc2 *callProc; + /* How to invoke this method. */ + Tcl_MethodDeleteProc *deleteProc; + /* How to delete this method's type-specific + * data, or NULL if the type-specific data + * does not need deleting. */ + Tcl_CloneProc *cloneProc; /* How to copy this method's type-specific + * data, or NULL if the type-specific data can + * be copied directly. */ +} Tcl_MethodType2; + /* * The correct value for the version field of the Tcl_MethodType structure. * This allows new versions of the structure to be introduced without breaking * binary compatability. */ +#define TCL_OO_METHOD_VERSION_1 1 +#define TCL_OO_METHOD_VERSION_2 2 #define TCL_OO_METHOD_VERSION_CURRENT 1 /* diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index d265c1a..5558ab2 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -369,7 +369,11 @@ TclOOInvokeContext( * Run the method implementation. */ - return mPtr->typePtr->callProc(mPtr->clientData, interp, + if (mPtr->typePtr->version == TCL_OO_METHOD_VERSION_1) { + return (mPtr->typePtr->callProc)(mPtr->clientData, interp, + (Tcl_ObjectContext) contextPtr, objc, objv); + } + return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp, (Tcl_ObjectContext) contextPtr, objc, objv); } diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 3be1e3d..f75d65a 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -123,6 +123,20 @@ TCLAPI Tcl_Class Tcl_GetClassOfObject(Tcl_Object object); /* 31 */ TCLAPI Tcl_Obj * Tcl_GetObjectClassName(Tcl_Interp *interp, Tcl_Object object); +/* 32 */ +TCLAPI int Tcl_MethodIsType2(Tcl_Method method, + const Tcl_MethodType2 *typePtr, + void **clientDataPtr); +/* 33 */ +TCLAPI Tcl_Method Tcl_NewInstanceMethod2(Tcl_Interp *interp, + Tcl_Object object, Tcl_Obj *nameObj, + int flags, const Tcl_MethodType2 *typePtr, + void *clientData); +/* 34 */ +TCLAPI Tcl_Method Tcl_NewMethod2(Tcl_Interp *interp, Tcl_Class cls, + Tcl_Obj *nameObj, int flags, + const Tcl_MethodType2 *typePtr, + void *clientData); typedef struct { const struct TclOOIntStubs *tclOOIntStubs; @@ -164,6 +178,9 @@ typedef struct TclOOStubs { int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */ Tcl_Class (*tcl_GetClassOfObject) (Tcl_Object object); /* 30 */ Tcl_Obj * (*tcl_GetObjectClassName) (Tcl_Interp *interp, Tcl_Object object); /* 31 */ + int (*tcl_MethodIsType2) (Tcl_Method method, const Tcl_MethodType2 *typePtr, void **clientDataPtr); /* 32 */ + Tcl_Method (*tcl_NewInstanceMethod2) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, void *clientData); /* 33 */ + Tcl_Method (*tcl_NewMethod2) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, void *clientData); /* 34 */ } TclOOStubs; extern const TclOOStubs *tclOOStubsPtr; @@ -242,6 +259,12 @@ extern const TclOOStubs *tclOOStubsPtr; (tclOOStubsPtr->tcl_GetClassOfObject) /* 30 */ #define Tcl_GetObjectClassName \ (tclOOStubsPtr->tcl_GetObjectClassName) /* 31 */ +#define Tcl_MethodIsType2 \ + (tclOOStubsPtr->tcl_MethodIsType2) /* 32 */ +#define Tcl_NewInstanceMethod2 \ + (tclOOStubsPtr->tcl_NewInstanceMethod2) /* 33 */ +#define Tcl_NewMethod2 \ + (tclOOStubsPtr->tcl_NewMethod2) /* 34 */ #endif /* defined(USE_TCLOO_STUBS) */ diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index ae1f3bd..29f86d4 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -187,6 +187,28 @@ Tcl_NewInstanceMethod( oPtr->epoch++; return (Tcl_Method) mPtr; } +Tcl_Method +Tcl_NewInstanceMethod2( + TCL_UNUSED(Tcl_Interp *), + Tcl_Object object, /* The object that has the method attached to + * it. */ + Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so, + * up to caller to manage storage (e.g., when + * it is a constructor or destructor). */ + int flags, /* Whether this is a public method. */ + const Tcl_MethodType2 *typePtr, + /* The type of method this is, which defines + * how to invoke, delete and clone the + * method. */ + void *clientData) /* Some data associated with the particular + * method to be created. */ +{ + if (typePtr->version == TCL_OO_METHOD_VERSION_1) { + Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewInstanceMethod2"); + } + return Tcl_NewInstanceMethod(NULL, object, nameObj, flags, + (const Tcl_MethodType *)typePtr, clientData); +} /* * ---------------------------------------------------------------------- @@ -255,6 +277,27 @@ Tcl_NewMethod( return (Tcl_Method) mPtr; } + +Tcl_Method +Tcl_NewMethod2( + TCL_UNUSED(Tcl_Interp *), + Tcl_Class cls, /* The class to attach the method to. */ + Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g., + * for constructors or destructors); if so, up + * to caller to manage storage. */ + int flags, /* Whether this is a public method. */ + const Tcl_MethodType2 *typePtr, + /* The type of method this is, which defines + * how to invoke, delete and clone the + * method. */ + void *clientData) /* Some data associated with the particular + * method to be created. */ +{ + if (typePtr->version == TCL_OO_METHOD_VERSION_1) { + Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewMethod2"); + } + return Tcl_NewMethod(NULL, cls, nameObj, flags, (const Tcl_MethodType *)typePtr, clientData); +} /* * ---------------------------------------------------------------------- @@ -1689,6 +1732,26 @@ Tcl_MethodIsType( } int +Tcl_MethodIsType2( + Tcl_Method method, + const Tcl_MethodType2 *typePtr, + void **clientDataPtr) +{ + Method *mPtr = (Method *) method; + + if (typePtr->version == TCL_OO_METHOD_VERSION_1) { + Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewInstanceMethod2"); + } + if (mPtr->typePtr == (const Tcl_MethodType *)typePtr) { + if (clientDataPtr != NULL) { + *clientDataPtr = mPtr->clientData; + } + return 1; + } + return 0; +} + +int Tcl_MethodIsPublic( Tcl_Method method) { diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c index b9034f0..7b653cb 100644 --- a/generic/tclOOStubInit.c +++ b/generic/tclOOStubInit.c @@ -76,6 +76,9 @@ const TclOOStubs tclOOStubs = { Tcl_MethodIsPrivate, /* 29 */ Tcl_GetClassOfObject, /* 30 */ Tcl_GetObjectClassName, /* 31 */ + Tcl_MethodIsType2, /* 32 */ + Tcl_NewInstanceMethod2, /* 33 */ + Tcl_NewMethod2, /* 34 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 -- cgit v0.12 From 59571d7b3fc9705ea9f18a0cff6cc2f37ebfa0f9 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 27 Jun 2022 16:02:37 +0000 Subject: Ticket #21280817 - Windows console rewrite to only create one thread per stdio channel. Functional, but not complete. --- win/tclWinConsole.c | 1961 +++++++++++++++++++++++++++++++++------------------ 1 file changed, 1294 insertions(+), 667 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index c3ba814..14cc6e5 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -2,15 +2,51 @@ * tclWinConsole.c -- * * This file implements the Windows-specific console functions, and the - * "console" channel driver. + * "console" channel driver. Windows 7 or later required. * - * Copyright © 1999 Scriptics Corp. + * Copyright © 2022 Ashok P. Nadkarni * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#define TCL_CONSOLE_DEBUG +#ifdef TCL_CONSOLE_DEBUG +#undef NDEBUG /* Enable asserts */ +#endif + #include "tclWinInt.h" +#include +#include + +/* + * A general note on the design: The console channel driver differs from most + * other drivers in the following respects: + * + * - There can be at most 3 console handles at any time since Windows does + * support allocation of more than one console (with three handles + * corresponding to stdin, stdout, stderr) + * + * - Consoles are created / inherited at process startup. There is currently + * no way in Tcl to programmatically create a console. Even if there were + * added the above Windows limitation would still apply. + * + * - Unlike files, sockets etc. where there is a one-to-one + * correspondence between Tcl channels and operating system handles, + * std* channels are shared amongst threads which means there can be + * multiple Tcl channels corresponding to a single console handle. + * + * - Even with multiple threads, more than one file event handler is unlikely. + * It does not make sense for multiple threads to register handlers for + * stdin because the input would be randomly fragmented amongst the threads + * (not even on a per line basis). + * + * Various design factors are driven by the above, e.g. use of lists instead + * of hash tables (at most 3 console handles) and use of global instead of + * per thread queues which simplifies lock management particularly because + * thread-console relation is not one-one and is likely more performant as + * well with fewer locks needing to be obtained. + */ /* * The following variable is used to tell whether this module has been @@ -19,106 +55,119 @@ static int initialized = 0; -/* - * The consoleMutex locks around access to the initialized variable, and it is - * used to protect background threads from being terminated while they are - * using APIs that hold locks. - */ - -TCL_DECLARE_MUTEX(consoleMutex) +#define CONSOLE_BUFFER_SIZE 8000 // TODO - must be at least 2 :-) /* - * Bit masks used in the flags field of the ConsoleInfo structure below. + * Ring buffer for storing data. Actual data is from bufPtr[start]:bufPtr[size-1] + * and bufPtr[0]:bufPtr[length - (size-start)]. */ - -#define CONSOLE_PENDING (1<<0) /* Message is pending in the queue. */ -#define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */ -#define CONSOLE_READ_OPS (1<<4) /* Channel supports read-related ops. */ -#define CONSOLE_RESET (1<<5) /* Console mode needs to be reset. */ +#if TCL_MAJOR_VERSION > 8 +typedef ptrdiff_t RingSizeT; /* Tcl9 TODO */ +#define RingSizeT_MAX PTRDIFF_MAX +#else +typedef int RingSizeT; +#define RingSizeT_MAX INT_MAX +#endif +typedef struct RingBuffer { + char *bufPtr; /* Pointer to buffer storage */ + RingSizeT capacity; /* Size of the buffer in RingBufferChar */ + RingSizeT start; /* Start of the data within the buffer. */ + RingSizeT length; /* Number of RingBufferChar*/ +} RingBuffer; +#define RingBufferLength(ringPtr_) ((ringPtr_)->length) +#define RingBufferFreeSpace(ringPtr_) ((ringPtr_)->capacity - (ringPtr_)->length) +#define RINGBUFFER_ASSERT(ringPtr_) assert(RingBufferCheck(ringPtr_)) /* - * Bit masks used in the sharedFlags field of the ConsoleInfo structure below. + * The Win32 console API does not support non-blocking I/O in any form. Thus + * the actual calls are made on a separate thread. Moreover, separate + * threads are needed for each handle because (for example) blocking on user + * input on stdin should not prevent output to stdout when non-blocking i/o + * is configured at the script level. + * + * In the input (e.g. stdin) case, the console stdin thread is the producer + * writing to the buffer ring buffer. The Tcl interpreter threads are the + * consumer. For the output (e.g. stdout/stderr) case, the Tcl interpreter + * are the producers while the console stdout/stderr threads are the + * consumers. + * + * Consoles are identified purely by handles and multiple threads may open + * them (as stdin/stdout/stderr are shared). + * + * Note on reference counting - a ConsoleHandleInfo instance has multiple + * references to it - one each from every channel that is attached to it + * plus one from the console thread itself which also serves as the reference + * from gConsoleHandleInfoList. */ - -#define CONSOLE_EOF (1<<2) /* Console has reached EOF. */ -#define CONSOLE_BUFFERED (1<<3) /* Data was read into a buffer by the reader - * thread. */ - -#define CONSOLE_BUFFER_SIZE (8*1024) - -/* - * Structure containing handles associated with one of the special console - * threads. - */ - -typedef struct { - HANDLE thread; /* Handle to reader or writer thread. */ - HANDLE readyEvent; /* Manual-reset event to signal _to_ the main - * thread when the worker thread has finished - * waiting for its normal work to happen. */ - TclPipeThreadInfo *TI; /* Thread info structure of writer and reader. */ -} ConsoleThreadInfo; +typedef struct ConsoleHandleInfo { + struct ConsoleHandleInfo *nextPtr; /* Process-global list of consoles */ + HANDLE console; /* Console handle */ + HANDLE consoleThread; /* Handle to thread doing actual i/o on the console */ + SRWLOCK lock; /* Controls access to this structure. + * Cheaper than CRITICAL_SECTION but note does not + * support recursive locks or Try* style attempts.*/ + CONDITION_VARIABLE consoleThreadCV;/* For awakening console thread */ + CONDITION_VARIABLE interpThreadCV; /* For awakening interpthread(s) */ + RingBuffer buffer; /* Buffer for data transferred between console + * threads and Tcl threads. For input consoles, + * written by the console thread and read by Tcl + * threads. The converse for output threads */ + DWORD initMode; /* Initial console mode. */ + DWORD lastError; /* An error caused by the last background + * operation. Set to 0 if no error has been + * detected. */ + int numRefs; /* See comments above */ + int permissions; /* TCL_READABLE for input consoles, TCL_WRITABLE + * for output. Only one or the other can be set. */ +} ConsoleHandleInfo; /* * This structure describes per-instance data for a console based channel. + * + * Note on locking - this structure has no locks because it is accessed + * only from the thread owning channel EXCEPT when a console traverses it + * looking for a channel that is watching for events on the console. Even + * in that case, no locking is required because that access is only under + * the consoleLock lock which prevents the channel from being removed from + * the gWatchingChannelList which in turn means it will not be deallocated + * from under the console thread. Access to individual fields does not need + * to be controlled because + * - the console thread does not write to any fields + * - changes to the nextWatchingChannelPtr field and CONSOLE_EVENT_QUEUE + * bit flags are under the gConsoleLock lock + * - changes to other fields do not matter because after being read for + * queueing events, they are verified again when the event is received + * in the interpreter thread (since they could have changed anyways while + * the event was in-flight on the event queue) + * + * Note on reference counting - a structure instance may be referenced from + * three places: + * - the Tcl channel subsystem. This reference is created when on channel + * opening and dropped on channel close. This also covers the reference + * from gWatchingChannelList since queueing / dequeuing from that list + * happens in conjunction with channel operations. + * - the Tcl event queue entries. This reference is added when the event + * is queued and dropped on receipt. */ - -typedef struct ConsoleInfo { - HANDLE handle; - int type; - struct ConsoleInfo *nextPtr;/* Pointer to next registered console. */ +typedef struct ConsoleChannelInfo { + HANDLE handle; /* Console handle */ + Tcl_ThreadId threadId; /* Id of owning thread */ + struct ConsoleChannelInfo + *nextWatchingChannelPtr; /* Pointer to next channel watching events. */ Tcl_Channel channel; /* Pointer to channel structure. */ - int validMask; /* OR'ed combination of TCL_READABLE, + DWORD initMode; /* Initial console mode. */ + int numRefs; /* See comments above */ + int permissions; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, or TCL_EXCEPTION: indicates * which operations are valid on the file. */ int watchMask; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, or TCL_EXCEPTION: indicates * which events should be reported. */ - int flags; /* State flags, see above for a list. */ - Tcl_ThreadId threadId; /* Thread to which events should be reported. - * This value is used by the reader/writer - * threads. */ - ConsoleThreadInfo writer; /* A specialized thread for handling - * asynchronous writes to the console; the - * waiting starts when a control event is sent, - * and a reset event is sent back to the main - * thread when the write is done. */ - ConsoleThreadInfo reader; /* A specialized thread for handling - * asynchronous reads from the console; the - * waiting starts when a control event is sent, - * and a reset event is sent back to the main - * thread when input is available. */ - DWORD writeError; /* An error caused by the last background - * write. Set to 0 if no error has been - * detected. This word is shared with the - * writer thread so access must be - * synchronized with the writable object. */ - char *writeBuf; /* Current background output buffer. Access is - * synchronized with the writable object. */ - int writeBufLen; /* Size of write buffer. Access is - * synchronized with the writable object. */ - int toWrite; /* Current amount to be written. Access is - * synchronized with the writable object. */ - int readFlags; /* Flags that are shared with the reader - * thread. Access is synchronized with the - * readable object. */ - int bytesRead; /* Number of bytes in the buffer. */ - int offset; /* Number of bytes read out of the buffer. */ - DWORD initMode; /* Initial console mode. */ - char buffer[CONSOLE_BUFFER_SIZE]; - /* Data consumed by reader thread. */ -} ConsoleInfo; - -typedef struct { - /* - * The following pointer refers to the head of the list of consoles that - * are being watched for file events. - */ - - ConsoleInfo *firstConsolePtr; -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; + int flags; /* State flags */ +#define CONSOLE_EVENT_QUEUED (1 << 0) /* Notification event already queued */ +#define CONSOLE_ASYNC (1 << 1) /* Channel is non-blocking. */ +#define CONSOLE_READ_OPS (1 << 2) /* Channel supports read-related ops. */ +} ConsoleChannelInfo; /* * The following structure is what is added to the Tcl event queue when @@ -126,51 +175,101 @@ static Tcl_ThreadDataKey dataKey; */ typedef struct { - Tcl_Event header; /* Information that is standard for all - * events. */ - ConsoleInfo *infoPtr; /* Pointer to console info structure. Note - * that we still have to verify that the - * console exists before dereferencing this - * pointer. */ + Tcl_Event header; /* Information that is standard for all events. */ + ConsoleChannelInfo *chanInfoPtr; /* Pointer to console info structure. Note + * that we still have to verify that the + * console exists before dereferencing this + * pointer. */ } ConsoleEvent; /* * Declarations for functions used only in this file. */ -static int ConsoleBlockModeProc(ClientData instanceData, - int mode); -static void ConsoleCheckProc(ClientData clientData, int flags); -static int ConsoleCloseProc(ClientData instanceData, - Tcl_Interp *interp, int flags); -static int ConsoleEventProc(Tcl_Event *evPtr, int flags); -static void ConsoleExitHandler(ClientData clientData); -static int ConsoleGetHandleProc(ClientData instanceData, - int direction, ClientData *handlePtr); -static int ConsoleGetOptionProc(ClientData instanceData, - Tcl_Interp *interp, const char *optionName, - Tcl_DString *dsPtr); -static void ConsoleInit(void); -static int ConsoleInputProc(ClientData instanceData, char *buf, - int toRead, int *errorCode); -static int ConsoleOutputProc(ClientData instanceData, - const char *buf, int toWrite, int *errorCode); +static int ConsoleBlockModeProc(ClientData instanceData, int mode); +static void ConsoleCheckProc(ClientData clientData, int flags); +static int ConsoleCloseProc(ClientData instanceData, + Tcl_Interp *interp, int flags); +static int ConsoleEventProc(Tcl_Event *evPtr, int flags); +static void ConsoleExitHandler(ClientData clientData); +static int ConsoleGetHandleProc(ClientData instanceData, + int direction, ClientData *handlePtr); +static int ConsoleGetOptionProc(ClientData instanceData, + Tcl_Interp *interp, const char *optionName, + Tcl_DString *dsPtr); +static void ConsoleInit(void); +static int ConsoleInputProc(ClientData instanceData, char *buf, + int toRead, int *errorCode); +static int ConsoleOutputProc(ClientData instanceData, + const char *buf, int toWrite, int *errorCode); +static int ConsoleSetOptionProc(ClientData instanceData, + Tcl_Interp *interp, const char *optionName, + const char *value); +static void ConsoleSetupProc(ClientData clientData, int flags); +static void ConsoleWatchProc(ClientData instanceData, int mask); +static void ProcExitHandler(ClientData clientData); +static void ConsoleThreadActionProc(ClientData instanceData, int action); +static DWORD ReadConsoleChars(HANDLE hConsole, WCHAR *lpBuffer, + RingSizeT nChars, RingSizeT *nCharsReadPtr); +static DWORD WriteConsoleChars(HANDLE hConsole, + const WCHAR *lpBuffer, RingSizeT nChars, + RingSizeT *nCharsWritten); +static void RingBufferInit(RingBuffer *ringPtr, RingSizeT capacity); +static void RingBufferClear(RingBuffer *ringPtr); +static char * RingBufferSegment(const RingBuffer *ringPtr, RingSizeT *lenPtr); +static int RingBufferCheck(const RingBuffer *ringPtr); +static RingSizeT RingBufferIn(RingBuffer *ringPtr, const char *srcPtr, + RingSizeT srcLen, int partialCopyOk); +static RingSizeT RingBufferOut(RingBuffer *ringPtr, char *dstPtr, + RingSizeT dstCapacity, int partialCopyOk); +static ConsoleHandleInfo *AllocateConsoleHandleInfo(HANDLE consoleHandle, + int permissions); +static ConsoleHandleInfo *FindConsoleInfo(const ConsoleChannelInfo *); static DWORD WINAPI ConsoleReaderThread(LPVOID arg); -static int ConsoleSetOptionProc(ClientData instanceData, - Tcl_Interp *interp, const char *optionName, - const char *value); -static void ConsoleSetupProc(ClientData clientData, int flags); -static void ConsoleWatchProc(ClientData instanceData, int mask); static DWORD WINAPI ConsoleWriterThread(LPVOID arg); -static void ProcExitHandler(ClientData clientData); -static int WaitForRead(ConsoleInfo *infoPtr, int blocking); -static void ConsoleThreadActionProc(ClientData instanceData, - int action); -static BOOL ReadConsoleBytes(HANDLE hConsole, LPVOID lpBuffer, - DWORD nbytes, LPDWORD nbytesread); -static BOOL WriteConsoleBytes(HANDLE hConsole, - const void *lpBuffer, DWORD nbytes, - LPDWORD nbyteswritten); +#ifdef OBSOLETE +static int WaitForRead(ConsoleChannelInfo *infoPtr, int blocking); +#endif + +/* + * Static data. + */ + +typedef struct { + /* Currently this struct is only used to detect thread initialization */ + int notUsed; /* Dummy field */ +} ThreadSpecificData; +static Tcl_ThreadDataKey dataKey; + +/* + * All access to static data is controlled through a single process-wide + * lock. A process can have only a single console at a time, with three + * handles for stdin, stdout and stderr. Creation/destruction of consoles is + * a relatively rare event (currently only possible during process start), + * the number of consoles (as opposed to channels) is small (only stdin, + * stdout and stderr), and contention low. More finer-grained locking would + * likely not only complicate implementation but be slower due to multiple + * locks being held. Note console channels also differ from other Tcl + * channel types in that the channel<->OS descriptor mapping is not one-to-one. + * + * The gConsoleLock locks around access to the initialized variable, and it + * is used to protect background threads from being terminated while they + * are using APIs that hold locks. TBD - is this still true? + */ +SRWLOCK gConsoleLock; + + +/* Process-wide list of console handles. Access control through gConsoleLock */ +static ConsoleHandleInfo *gConsoleHandleInfoList; + +/* + * Process-wide list of channels that are listening for events. Again access + * control through gConsoleLock. Common list for all threads is simplifies + * locking and bookkeeping and is workable because in practice multiple + * threads are very unlikely to be all waiting on stdin (not workable + * because input would be randomly distributed to threads) + */ +static ConsoleChannelInfo *gWatchingChannelList; /* * This structure describes the channel type structure for command console @@ -178,82 +277,350 @@ static BOOL WriteConsoleBytes(HANDLE hConsole, */ static const Tcl_ChannelType consoleChannelType = { - "console", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel */ - TCL_CLOSE2PROC, /* Close proc. */ - ConsoleInputProc, /* Input proc. */ - ConsoleOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ - ConsoleSetOptionProc, /* Set option proc. */ - ConsoleGetOptionProc, /* Get option proc. */ - ConsoleWatchProc, /* Set up notifier to watch the channel. */ - ConsoleGetHandleProc, /* Get an OS handle from channel. */ - ConsoleCloseProc, /* close2proc. */ - ConsoleBlockModeProc, /* Set blocking or non-blocking mode. */ - NULL, /* Flush proc. */ - NULL, /* Handler proc. */ - NULL, /* Wide seek proc. */ - ConsoleThreadActionProc, /* Thread action proc. */ - NULL /* Truncation proc. */ + "console", /* Type name. */ + TCL_CHANNEL_VERSION_5, /* v5 channel */ + TCL_CLOSE2PROC, /* Close proc. */ + ConsoleInputProc, /* Input proc. */ + ConsoleOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + ConsoleSetOptionProc, /* Set option proc. */ + ConsoleGetOptionProc, /* Get option proc. */ + ConsoleWatchProc, /* Set up notifier to watch the channel. */ + ConsoleGetHandleProc, /* Get an OS handle from channel. */ + ConsoleCloseProc, /* close2proc. */ + ConsoleBlockModeProc, /* Set blocking or non-blocking mode. */ + NULL, /* Flush proc. */ + NULL, /* Handler proc. */ + NULL, /* Wide seek proc. */ + ConsoleThreadActionProc, /* Thread action proc. */ + NULL /* Truncation proc. */ }; + +/* + *------------------------------------------------------------------------ + * + * RingBufferInit -- + * + * Initializes the ring buffer to a given size. + * + * Results: + * None. + * + * Side effects: + * Panics on allocation failure. + * + *------------------------------------------------------------------------ + */ +static void +RingBufferInit(RingBuffer *ringPtr, RingSizeT capacity) +{ + if (capacity <= 0 || capacity > RingSizeT_MAX) { + Tcl_Panic("Internal error: invalid ring buffer capacity requested."); + } + ringPtr->bufPtr = (char *)ckalloc(capacity); + ringPtr->capacity = capacity; + ringPtr->start = 0; + ringPtr->length = 0; +} /* - *---------------------------------------------------------------------- + *------------------------------------------------------------------------ * - * ReadConsoleBytes, WriteConsoleBytes -- + * RingBufferClear * - * Wrapper for ReadConsoleW, that takes and returns number of bytes - * instead of number of WCHARS. + * Clears the contents of a ring buffer. * - *---------------------------------------------------------------------- + * Results: + * None. + * + * Side effects: + * The allocated internal buffer is freed. + * + *------------------------------------------------------------------------ + */ +static void +RingBufferClear(RingBuffer *ringPtr) +{ + if (ringPtr->bufPtr) { + ckfree(ringPtr->bufPtr); + ringPtr->bufPtr = NULL; + } + ringPtr->capacity = 0; + ringPtr->start = 0; + ringPtr->length = 0; +} + +/* + *------------------------------------------------------------------------ + * + * RingBufferIn -- + * + * Appends data to the ring buffer. + * + * Results: + * Returns number of bytes copied. + * + * Side effects: + * Internal buffer is updated. + * + *------------------------------------------------------------------------ + */ +static RingSizeT +RingBufferIn( + RingBuffer *ringPtr, + const char *srcPtr, /* Source to be copied */ + RingSizeT srcLen, /* Length of source */ + int partialCopyOk /* If true, partial copy is permitted */ + ) +{ + RingSizeT freeSpace; + RingSizeT endSpace; + + RINGBUFFER_ASSERT(ringPtr); + + freeSpace = ringPtr->capacity - ringPtr->length; + if (freeSpace < srcLen) { + if (!partialCopyOk) { + return 0; + } + /* Copy only as much as free space allows */ + srcLen = freeSpace; + } + + /* Copy as much as possible to the tail */ + if (ringPtr->capacity - ringPtr->start > ringPtr->length) { + /* There is room at the back */ + RingSizeT endSpaceStart = ringPtr->start + ringPtr->length; + endSpace = ringPtr->capacity - endSpaceStart; + if (endSpace > srcLen) { + endSpace = srcLen; + } + memmove(endSpaceStart + ringPtr->bufPtr, srcPtr, endSpace); + } + else { + endSpace = 0; + } + + /* Wrap around any left over data. Have already copied endSpace bytes */ + if (srcLen > endSpace) { + memmove(ringPtr->bufPtr, endSpace + srcPtr, srcLen - endSpace); + } + + ringPtr->length += srcLen; + + RINGBUFFER_ASSERT(ringPtr); + + return srcLen; +} + +/* + *------------------------------------------------------------------------ + * + * RingBufferOut -- + * + * Moves data out of the ring buffer. If dstPtr is NULL, the data + * is simply removed. + * + * Results: + * Returns number of bytes copied or removed. + * + * Side effects: + * Internal buffer is updated. + * + *------------------------------------------------------------------------ + */ +static RingSizeT +RingBufferOut(RingBuffer *ringPtr, + char *dstPtr, /* Buffer for output data. May be NULL */ + RingSizeT dstCapacity, /* Size of buffer */ + int partialCopyOk) /* If true, return what's available */ +{ + RingSizeT leadLen; + + RINGBUFFER_ASSERT(ringPtr); + + if (dstCapacity > ringPtr->length) { + if (dstPtr && !partialCopyOk) { + return 0; + } + dstCapacity = ringPtr->length; + } + + if (ringPtr->start <= (ringPtr->capacity - ringPtr->length)) { + /* No content wrap around. So leadLen is entire content */ + leadLen = ringPtr->length; + } + else { + /* Content wraps around so lead segment stretches to end of buffer */ + leadLen = ringPtr->capacity - ringPtr->start; + } + if (leadLen >= dstCapacity) { + if (dstPtr) { + memmove(dstPtr, ringPtr->start + ringPtr->bufPtr, dstCapacity); + } + ringPtr->start += dstCapacity; + } + else { + RingSizeT wrapLen = dstCapacity - leadLen; + if (dstPtr) { + memmove(dstPtr, + ringPtr->start + ringPtr->bufPtr, + leadLen); + memmove( + leadLen + dstPtr, ringPtr->bufPtr, wrapLen); + } + ringPtr->start = wrapLen; + } + + ringPtr->length -= dstCapacity; + if (ringPtr->start == ringPtr->capacity || ringPtr->length == 0) { + ringPtr->start = 0; + } + + RINGBUFFER_ASSERT(ringPtr); + + return dstCapacity; +} + +/* + *------------------------------------------------------------------------ + * + * RingBufferSegment -- + * + * Returns a pointer to the leading data segment in the ring buffer. + * + * Results: + * Pointer to start of segment. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ */ + static char * + RingBufferSegment(const RingBuffer *ringPtr, RingSizeT *lengthPtr) +{ + RINGBUFFER_ASSERT(ringPtr); + if (ringPtr->length <= (ringPtr->capacity - ringPtr->start)) { + /* No content wrap around. */ + *lengthPtr = ringPtr->length; + } + else { + /* Content wraps around so lead segment stretches to end of buffer */ + *lengthPtr = ringPtr->capacity - ringPtr->start; + } + return *lengthPtr == 0 ? NULL : ringPtr->start + ringPtr->bufPtr; +} + +static int +RingBufferCheck(const RingBuffer *ringPtr) +{ + return (ringPtr->bufPtr != NULL && ringPtr->capacity == CONSOLE_BUFFER_SIZE + && ringPtr->start < ringPtr->capacity + && ringPtr->length <= ringPtr->capacity); +} -static BOOL -ReadConsoleBytes( +/* + *------------------------------------------------------------------------ + * + * ReadConsoleChars -- + * + * Wrapper for ReadConsoleW. + * + * Results: + * Returns 0 on success, else Windows error code. + * + * Side effects: + * On success the number of characters (not bytes) read is stored in + * *nCharsReadPtr. This will be 0 if the operation was interrupted by + * a Ctrl-C or a CancelIo call. + * + *------------------------------------------------------------------------ + */ +static DWORD +ReadConsoleChars( HANDLE hConsole, - LPVOID lpBuffer, - DWORD nbytes, - LPDWORD nbytesread) + WCHAR *lpBuffer, + RingSizeT nChars, + RingSizeT *nCharsReadPtr) { - DWORD ntchars; + DWORD nRead; BOOL result; /* - * If user types a Ctrl-Break or Ctrl-C, ReadConsole will return - * success with ntchars == 0 and GetLastError() will be - * ERROR_OPERATION_ABORTED. We do not want to treat this case - * as EOF so we will loop around again. If no Ctrl signal handlers - * have been established, the default signal OS handler in a separate - * thread will terminate the program. If a Ctrl signal handler - * has been established (through an extension for example), it - * will run and take whatever action it deems appropriate. + * If user types a Ctrl-Break or Ctrl-C, ReadConsole will return success + * with ntchars == 0 and GetLastError() will be ERROR_OPERATION_ABORTED. + * If no Ctrl signal handlers have been established, the default signal + * OS handler in a separate thread will terminate the program. If a Ctrl + * signal handler has been established (through an extension for + * example), it will run and take whatever action it deems appropriate. + * + * If one thread closes its channel, it calls CancelSynchronousIo on the + * console handle which results again in success being returned and + * GetLastError() being ERROR_OPERATION_ABORTED but ntchars in + * unmodified. + * + * In both cases above we will return success but with nbytesread as 0. + * This allows caller to check for thread termination etc. + * + * See https://bugs.python.org/issue30237 + * or https://github.com/microsoft/terminal/issues/12143 */ - do { - result = ReadConsoleW(hConsole, lpBuffer, nbytes / sizeof(WCHAR), &ntchars, - NULL); - } while (result && ntchars == 0 && GetLastError() == ERROR_OPERATION_ABORTED); - if (nbytesread != NULL) { - *nbytesread = ntchars * sizeof(WCHAR); - } - return result; + nRead = (DWORD)-1; + result = ReadConsoleW(hConsole, lpBuffer, nChars, &nRead, NULL); + if (result) { + if ((nRead == 0 || nRead == (DWORD)-1) + && GetLastError() == ERROR_OPERATION_ABORTED) { + nRead = 0; + } + *nCharsReadPtr = nRead; + return 0; + } + else + return GetLastError(); } + +/* + *------------------------------------------------------------------------ + * + * WriteConsoleChars -- + * + * Wrapper for WriteConsoleW. + * + * Results: + * Returns 0 on success, Windows error code on failure. + * + * Side effects: + * On success the number of characters (not bytes) written is stored in + * *nCharsWrittenPtr. This will be 0 if the operation was interrupted by + * a Ctrl-C or a CancelIo call. + * + *------------------------------------------------------------------------ + */ -static BOOL -WriteConsoleBytes( +static DWORD +WriteConsoleChars( HANDLE hConsole, - const void *lpBuffer, - DWORD nbytes, - LPDWORD nbyteswritten) + const WCHAR *lpBuffer, + RingSizeT nChars, + RingSizeT *nCharsWrittenPtr) { - DWORD ntchars; + DWORD nCharsWritten; BOOL result; - result = WriteConsoleW(hConsole, lpBuffer, nbytes / sizeof(WCHAR), &ntchars, - NULL); - if (nbyteswritten != NULL) { - *nbyteswritten = ntchars * sizeof(WCHAR); + /* See comments in ReadConsoleChars, not sure that applies here */ + nCharsWritten = (DWORD)-1; + result = WriteConsoleW(hConsole, lpBuffer, nChars, &nCharsWritten, NULL); + if (result) { + if (nCharsWritten == (DWORD) -1) { + nCharsWritten = 0; + } + *nCharsWrittenPtr = nCharsWritten; + return 0; + } + else { + return GetLastError(); } - return result; } /* @@ -281,18 +648,18 @@ ConsoleInit(void) */ if (!initialized) { - Tcl_MutexLock(&consoleMutex); + AcquireSRWLockExclusive(&gConsoleLock); if (!initialized) { initialized = 1; Tcl_CreateExitHandler(ProcExitHandler, NULL); } - Tcl_MutexUnlock(&consoleMutex); + ReleaseSRWLockExclusive(&gConsoleLock); } if (TclThreadDataKeyGet(&dataKey) == NULL) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - tsdPtr->firstConsolePtr = NULL; + tsdPtr->notUsed = 0; Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL); Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL); } @@ -343,9 +710,9 @@ static void ProcExitHandler( TCL_UNUSED(ClientData)) { - Tcl_MutexLock(&consoleMutex); + AcquireSRWLockExclusive(&gConsoleLock); initialized = 0; - Tcl_MutexUnlock(&consoleMutex); + ReleaseSRWLockExclusive(&gConsoleLock); } /* @@ -354,7 +721,9 @@ ProcExitHandler( * ConsoleSetupProc -- * * This procedure is invoked before Tcl_DoOneEvent blocks waiting for an - * event. + * event. It walks the channel list and if any input channel has data + * available or output channel has space for data, sets the event loop + * blocking time to 0 so that it will poll immediately. * * Results: * None. @@ -370,34 +739,40 @@ ConsoleSetupProc( TCL_UNUSED(ClientData), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { - ConsoleInfo *infoPtr; + ConsoleChannelInfo *chanInfoPtr; Tcl_Time blockTime = { 0, 0 }; int block = 1; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } /* - * Look to see if any events are already pending. If they are, poll. + * Walk the list of channels. See general comments for struct + * ConsoleChannelInfo with regard to locking and field access. */ - - for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->watchMask & TCL_WRITABLE) { - if (WaitForSingleObject(infoPtr->writer.readyEvent, - 0) != WAIT_TIMEOUT) { - block = 0; + AcquireSRWLockShared(&gConsoleLock); /* READ lock - no data modification */ + + for (chanInfoPtr = gWatchingChannelList; block && chanInfoPtr != NULL; + chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) { + ConsoleHandleInfo *handleInfoPtr; + handleInfoPtr = FindConsoleInfo(chanInfoPtr); + if (handleInfoPtr != NULL) { + AcquireSRWLockShared(&handleInfoPtr->lock); + if ((chanInfoPtr->watchMask & TCL_READABLE) + && RingBufferLength(&handleInfoPtr->buffer) > 0) { + block = 0; /* Input data available */ } - } - if (infoPtr->watchMask & TCL_READABLE) { - if (WaitForRead(infoPtr, 0) >= 0) { - block = 0; + else if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { + block = 0; /* Output space available */ } + ReleaseSRWLockShared(&handleInfoPtr->lock); } } + ReleaseSRWLockShared(&gConsoleLock); + if (!block) { + /* At least one channel is readable/writable. Set block time to 0 */ Tcl_SetMaxBlockTime(&blockTime); } } @@ -424,54 +799,69 @@ ConsoleCheckProc( TCL_UNUSED(ClientData), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { - ConsoleInfo *infoPtr; + ConsoleChannelInfo *chanInfoPtr; + Tcl_ThreadId me; int needEvent; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!(flags & TCL_FILE_EVENTS)) { return; } + me = Tcl_GetCurrentThread(); + /* - * Queue events for any ready consoles that don't already have events - * queued. + * Acquire a shared lock. Note this is ok even though we potentially + * modify the chanInfoPtr->flags because chanInfoPtr is only modified + * when it belongs to this thread and no other thread will write to it. + * THe shared lock is intended to protect the global gWatchingChannelList + * as we traverse it. */ + AcquireSRWLockShared(&gConsoleLock); + + for (chanInfoPtr = gWatchingChannelList; chanInfoPtr != NULL; + chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) { + ConsoleHandleInfo *handleInfoPtr; - for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->flags & CONSOLE_PENDING) { + if (chanInfoPtr->threadId != me) { + /* Some other thread owns the channel */ + continue; + } + if (chanInfoPtr->flags & CONSOLE_EVENT_QUEUED) { + /* A notification event already queued. No point in another. */ continue; } - /* - * Queue an event if the console is signaled for reading or writing. - */ + handleInfoPtr = FindConsoleInfo(chanInfoPtr); + /* Pointer is safe to access as we are holding gConsoleLock */ - needEvent = 0; - if (infoPtr->watchMask & TCL_WRITABLE) { - if (WaitForSingleObject(infoPtr->writer.readyEvent, - 0) != WAIT_TIMEOUT) { - needEvent = 1; + if (handleInfoPtr != NULL) { + AcquireSRWLockShared(&handleInfoPtr->lock); + if ((chanInfoPtr->watchMask & TCL_READABLE) + && RingBufferLength(&handleInfoPtr->buffer) > 0) { + needEvent = 1; /* Input data available */ } - } - - if (infoPtr->watchMask & TCL_READABLE) { - if (WaitForRead(infoPtr, 0) >= 0) { - needEvent = 1; + else if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { + needEvent = 1; /* Output space available */ } + ReleaseSRWLockShared(&handleInfoPtr->lock); } if (needEvent) { ConsoleEvent *evPtr = (ConsoleEvent *)ckalloc(sizeof(ConsoleEvent)); - infoPtr->flags |= CONSOLE_PENDING; + /* See note above loop why this can be accessed without locks */ + chanInfoPtr->flags |= CONSOLE_EVENT_QUEUED; + chanInfoPtr->numRefs += 1; /* So it does not go away while event + is in queue */ evPtr->header.proc = ConsoleEventProc; - evPtr->infoPtr = infoPtr; + evPtr->chanInfoPtr = chanInfoPtr; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); } } + + ReleaseSRWLockShared(&gConsoleLock); } - + /* *---------------------------------------------------------------------- * @@ -494,7 +884,7 @@ ConsoleBlockModeProc( int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { - ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData; + ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; /* * Consoles on Windows can not be switched between blocking and @@ -505,9 +895,9 @@ ConsoleBlockModeProc( */ if (mode == TCL_MODE_NONBLOCKING) { - infoPtr->flags |= CONSOLE_ASYNC; + chanInfoPtr->flags |= CONSOLE_ASYNC; } else { - infoPtr->flags &= ~CONSOLE_ASYNC; + chanInfoPtr->flags &= ~CONSOLE_ASYNC; } return 0; } @@ -530,102 +920,86 @@ ConsoleBlockModeProc( static int ConsoleCloseProc( - ClientData instanceData, /* Pointer to ConsoleInfo structure. */ + ClientData instanceData, /* Pointer to ConsoleChannelInfo structure. */ TCL_UNUSED(Tcl_Interp *), int flags) { - ConsoleInfo *consolePtr = (ConsoleInfo *)instanceData; + ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; + ConsoleHandleInfo *handleInfoPtr; int errorCode = 0; - ConsoleInfo *infoPtr, **nextPtrPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ConsoleChannelInfo **nextPtrPtr; if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) { return EINVAL; } - /* - * Clean up the background thread if necessary. Note that this must be - * done before we can close the file, since the thread may be blocking - * trying to read from the console. - */ + AcquireSRWLockExclusive(&gConsoleLock); - if (consolePtr->reader.thread) { - TclPipeThreadStop(&consolePtr->reader.TI, consolePtr->reader.thread); - CloseHandle(consolePtr->reader.thread); - CloseHandle(consolePtr->reader.readyEvent); - consolePtr->reader.thread = NULL; + /* Remove channel from watchers' list */ + for (nextPtrPtr = &gWatchingChannelList; *nextPtrPtr != NULL; + nextPtrPtr = &(*nextPtrPtr)->nextWatchingChannelPtr) { + if (*nextPtrPtr == (ConsoleChannelInfo *) chanInfoPtr) { + *nextPtrPtr = (*nextPtrPtr)->nextWatchingChannelPtr; + break; + } } - consolePtr->validMask &= ~TCL_READABLE; - /* - * Wait for the writer thread to finish the current buffer, then terminate - * the thread and close the handles. If the channel is nonblocking, there - * should be no pending write operations. - */ - - if (consolePtr->writer.thread) { - if (consolePtr->toWrite) { - /* - * We only need to wait if there is something to write. This may - * prevent infinite wait on exit. [Python Bug 216289] - */ + handleInfoPtr = FindConsoleInfo(chanInfoPtr); + if (handleInfoPtr) { + /* + * Console thread may be blocked either waiting for console i/o + * or waiting on the condition variable for buffer empty/full + */ + AcquireSRWLockShared(&handleInfoPtr->lock); - WaitForSingleObject(consolePtr->writer.readyEvent, 5000); - } + handleInfoPtr->numRefs -= 1; /* Remove reference from this channel */ - TclPipeThreadStop(&consolePtr->writer.TI, consolePtr->writer.thread); - CloseHandle(consolePtr->writer.thread); - CloseHandle(consolePtr->writer.readyEvent); - consolePtr->writer.thread = NULL; - } - consolePtr->validMask &= ~TCL_WRITABLE; + /* Break the thread out of blocking console i/o */ + CancelSynchronousIo(handleInfoPtr->consoleThread); - /* - * If the user has been tinkering with the mode, reset it now. We ignore - * any errors from this; we're quite possibly about to close or exit - * anyway. - */ + /* Wake up the console handling thread */ + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); - if ((consolePtr->flags & CONSOLE_READ_OPS) && - (consolePtr->flags & CONSOLE_RESET)) { - SetConsoleMode(consolePtr->handle, consolePtr->initMode); + ReleaseSRWLockShared(&handleInfoPtr->lock); } - /* - * Don't close the Win32 handle if the handle is a standard channel during - * the thread exit process. Otherwise, one thread may kill the stdio of - * another. - */ + ReleaseSRWLockExclusive(&gConsoleLock); - if (!TclInThreadExit() - || ((GetStdHandle(STD_INPUT_HANDLE) != consolePtr->handle) - && (GetStdHandle(STD_OUTPUT_HANDLE) != consolePtr->handle) - && (GetStdHandle(STD_ERROR_HANDLE) != consolePtr->handle))) { - if (CloseHandle(consolePtr->handle) == FALSE) { - Tcl_WinConvertError(GetLastError()); - errorCode = errno; + chanInfoPtr->channel = NULL; + chanInfoPtr->watchMask = 0; + chanInfoPtr->permissions = 0; + + if (chanInfoPtr->handle) { + /* + * Don't close the Win32 handle if the handle is a standard channel + * during the thread exit process. Otherwise, one thread may kill the + * stdio of another. TODO - an explicit close in script will still close + * it. + */ + if (!TclInThreadExit() + || ((GetStdHandle(STD_INPUT_HANDLE) != chanInfoPtr->handle) + && (GetStdHandle(STD_OUTPUT_HANDLE) != chanInfoPtr->handle) + && (GetStdHandle(STD_ERROR_HANDLE) != chanInfoPtr->handle))) { + if (CloseHandle(chanInfoPtr->handle) == FALSE) { + Tcl_WinConvertError(GetLastError()); + errorCode = errno; + } } + chanInfoPtr->handle = NULL; } - consolePtr->watchMask &= consolePtr->validMask; - /* - * Remove the file from the list of watched files. + * Note, we can check and manipulate numRefs without a lock because + * we have removed it from the watch queue so the console thread cannot + * get at it. */ - - for (nextPtrPtr = &tsdPtr->firstConsolePtr, infoPtr = *nextPtrPtr; - infoPtr != NULL; - nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) { - if (infoPtr == (ConsoleInfo *) consolePtr) { - *nextPtrPtr = infoPtr->nextPtr; - break; - } + if (chanInfoPtr->numRefs > 1) { + /* There may be references already on the event queue */ + chanInfoPtr->numRefs -= 1; } - if (consolePtr->writeBuf != NULL) { - ckfree(consolePtr->writeBuf); - consolePtr->writeBuf = 0; + else { + ckfree(chanInfoPtr); } - ckfree(consolePtr); return errorCode; } @@ -647,80 +1021,85 @@ ConsoleCloseProc( * *---------------------------------------------------------------------- */ - static int ConsoleInputProc( ClientData instanceData, /* Console state. */ - char *buf, /* Where to store data read. */ + char *bufPtr, /* Where to store data read. */ int bufSize, /* How much space is available in the * buffer? */ int *errorCode) /* Where to store error code. */ { - ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData; - DWORD count, bytesRead = 0; - int result; + ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; + ConsoleHandleInfo *handleInfoPtr; + RingSizeT numRead; *errorCode = 0; - /* - * Synchronize with the reader thread. - */ - - result = WaitForRead(infoPtr, (infoPtr->flags & CONSOLE_ASYNC) ? 0 : 1); - - /* - * If an error occurred, return immediately. - */ - - if (result == -1) { - *errorCode = errno; - return -1; + AcquireSRWLockShared(&gConsoleLock); + handleInfoPtr = FindConsoleInfo(chanInfoPtr); + if (handleInfoPtr == NULL) { + /* Really shouldn't happen since channel is holding a reference */ + ReleaseSRWLockShared(&gConsoleLock); + return 0; /* EOF */ } + AcquireSRWLockExclusive(&handleInfoPtr->lock); + ReleaseSRWLockShared(&gConsoleLock); /* AFTER acquiring handleInfoPtr->lock */ - if (infoPtr->readFlags & CONSOLE_BUFFERED) { + numRead = RingBufferOut(&handleInfoPtr->buffer, bufPtr, bufSize, 1); + while (numRead == 0) { /* - * Data is stored in the buffer. + * No data available. + * - If an error was recorded, generate that and reset it. + * - If EOF, indicate as much. TODO - can console thread still be + * running in that case? + * - Otherwise, if non-blocking return EAGAIN or wait for more data. */ - - if (bufSize < (infoPtr->bytesRead - infoPtr->offset)) { - memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize); - bytesRead = bufSize; - infoPtr->offset += bufSize; - } else { - memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize); - bytesRead = infoPtr->bytesRead - infoPtr->offset; - - /* - * Reset the buffer. - */ - - infoPtr->readFlags &= ~CONSOLE_BUFFERED; - infoPtr->offset = 0; + if (handleInfoPtr->lastError != 0) { + Tcl_WinConvertError(handleInfoPtr->lastError); + handleInfoPtr->lastError = 0; + *errorCode = Tcl_GetErrno(); + numRead = -1; + } + else if (handleInfoPtr->console == NULL) { + /* EOF - break with numRead == 0 */ + break; + } + else { + if (chanInfoPtr->flags & CONSOLE_ASYNC) { + *errorCode = EAGAIN; + numRead = -1; + } + else { + /* + * Release the lock and sleep. Note that because the channel + * holds a reference count on handleInfoPtr, it will not + * be deallocated while the lock is released. + */ + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + if (SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, + &handleInfoPtr->lock, + INFINITE, + 0)) { + /* + * Lock is reacquired. However, in the meanwhile another + * thread could have consumed data. So loop continues + * with check of numRead value. + */ + numRead = RingBufferOut( + &handleInfoPtr->buffer, bufPtr, bufSize, 1); + } + else { + /* Report the error */ + Tcl_WinConvertError(GetLastError()); + *errorCode = Tcl_GetErrno(); + numRead = -1; + } + } } - - return bytesRead; - } - - /* - * Attempt to read bufSize bytes. The read will return immediately if - * there is any data available. Otherwise it will block until at least one - * byte is available or an EOF occurs. - */ - - if (ReadConsoleBytes(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, - &count) == TRUE) { - /* - * TODO: This potentially writes beyond the limits specified - * by the caller. In practice this is harmless, since all writes - * are into ChannelBuffers, and those have padding, but still - * ought to remove this, unless some Windows wizard can give - * a reason not to. - */ - buf[count] = '\0'; - return count; } - return -1; + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + return numRead; } /* @@ -740,7 +1119,6 @@ ConsoleInputProc( * *---------------------------------------------------------------------- */ - static int ConsoleOutputProc( ClientData instanceData, /* Console state. */ @@ -748,74 +1126,70 @@ ConsoleOutputProc( int toWrite, /* How many bytes to write? */ int *errorCode) /* Where to store error code. */ { - ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData; - ConsoleThreadInfo *threadInfo = &infoPtr->writer; - DWORD bytesWritten, timeout; + ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; + ConsoleHandleInfo *handleInfoPtr; + RingSizeT numWritten; *errorCode = 0; - /* avoid blocking if pipe-thread exited */ - timeout = (infoPtr->flags & CONSOLE_ASYNC) || !TclPipeThreadIsAlive(&threadInfo->TI) - || TclInExit() || TclInThreadExit() ? 0 : INFINITE; - if (WaitForSingleObject(threadInfo->readyEvent, timeout) == WAIT_TIMEOUT) { - /* - * The writer thread is blocked waiting for a write to complete and - * the channel is in non-blocking mode. - */ - - errno = EWOULDBLOCK; - goto error; - } - - /* - * Check for a background error on the last write. - */ - - if (infoPtr->writeError) { - Tcl_WinConvertError(infoPtr->writeError); - infoPtr->writeError = 0; - goto error; + AcquireSRWLockShared(&gConsoleLock); + handleInfoPtr = FindConsoleInfo(chanInfoPtr); + if (handleInfoPtr == NULL) { + /* Really shouldn't happen since channel is holding a reference */ + *errorCode = EPIPE; + ReleaseSRWLockShared(&gConsoleLock); + return -1; } - - if (infoPtr->flags & CONSOLE_ASYNC) { - /* - * The console is non-blocking, so copy the data into the output - * buffer and restart the writer thread. - */ - - if (toWrite > infoPtr->writeBufLen) { + AcquireSRWLockExclusive(&handleInfoPtr->lock); + ReleaseSRWLockShared(&gConsoleLock); /* AFTER acquiring handleInfoPtr->lock */ + + numWritten = RingBufferIn(&handleInfoPtr->buffer, buf, toWrite, 1); + while (numWritten < toWrite) { + if (handleInfoPtr->lastError != 0) { + Tcl_WinConvertError(handleInfoPtr->lastError); + *errorCode = Tcl_GetErrno(); + numWritten = -1; + break; + } + if (handleInfoPtr->console == NULL) { + *errorCode = EPIPE; + numWritten = -1; + break; + } + if (chanInfoPtr->flags & CONSOLE_ASYNC) { + /* Async, just accept whatever was written */ + break; + } + else { /* - * Reallocate the buffer to be large enough to hold the data. + * Release the lock and sleep. Note that because the channel + * holds a reference count on handleInfoPtr, it will not + * be deallocated while the lock is released. */ - - if (infoPtr->writeBuf) { - ckfree(infoPtr->writeBuf); + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + if (SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, + &handleInfoPtr->lock, + INFINITE, + 0)) { + /* Lock is reacquired. Continue loop */ + numWritten += RingBufferIn(&handleInfoPtr->buffer, + numWritten + buf, + toWrite - numWritten, + 1); + } + else { + /* Report the error */ + Tcl_WinConvertError(GetLastError()); + *errorCode = Tcl_GetErrno(); + numWritten = -1; + break; } - infoPtr->writeBufLen = toWrite; - infoPtr->writeBuf = (char *)ckalloc(toWrite); - } - memcpy(infoPtr->writeBuf, buf, toWrite); - infoPtr->toWrite = toWrite; - ResetEvent(threadInfo->readyEvent); - TclPipeThreadSignal(&threadInfo->TI); - bytesWritten = toWrite; - } else { - /* - * In the blocking case, just try to write the buffer directly. This - * avoids an unnecessary copy. - */ - - if (WriteConsoleBytes(infoPtr->handle, buf, (DWORD) toWrite, - &bytesWritten) == FALSE) { - Tcl_WinConvertError(GetLastError()); - goto error; } } - return bytesWritten; - error: - *errorCode = errno; - return -1; + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + return numWritten; } /* @@ -846,66 +1220,69 @@ ConsoleEventProc( * such as TCL_FILE_EVENTS. */ { ConsoleEvent *consoleEvPtr = (ConsoleEvent *) evPtr; - ConsoleInfo *infoPtr; - int mask; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ConsoleChannelInfo *chanInfoPtr; + int freeChannel; if (!(flags & TCL_FILE_EVENTS)) { return 0; } + chanInfoPtr = consoleEvPtr->chanInfoPtr; /* - * Search through the list of watched consoles for the one whose handle - * matches the event. We do this rather than simply dereferencing the - * handle in the event so that consoles can be deleted while the event is - * in the queue. - */ - - for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (consoleEvPtr->infoPtr == infoPtr) { - infoPtr->flags &= ~CONSOLE_PENDING; - break; - } - } - - /* - * Remove stale events. + * We know chanInfoPtr is valid because its reference count would have + * been incremented when the event was queued. The corresponding release + * happens in this function. */ - if (!infoPtr) { - return 1; - } + AcquireSRWLockShared(&gConsoleLock); + chanInfoPtr->flags &= ~CONSOLE_EVENT_QUEUED; /* - * Check to see if the console is readable. Note that we can't tell if a - * console is writable, so we always report it as being writable unless we - * have detected EOF. + * Only handle the event if the Tcl channel has not gone away AND is + * still owned by this thread AND is still watching events. */ - - mask = 0; - if (infoPtr->watchMask & TCL_WRITABLE) { - if (WaitForSingleObject(infoPtr->writer.readyEvent, - 0) != WAIT_TIMEOUT) { - mask = TCL_WRITABLE; + if (chanInfoPtr->channel && chanInfoPtr->threadId == Tcl_GetCurrentThread() + && (chanInfoPtr->watchMask & (TCL_READABLE|TCL_WRITABLE))) { + ConsoleHandleInfo *handleInfoPtr; + int mask = 0; + handleInfoPtr = FindConsoleInfo(chanInfoPtr); + if (handleInfoPtr == NULL) { + /* Console was closed. EOF->read event only (not write) */ + if (chanInfoPtr->watchMask & TCL_READABLE) { + mask = TCL_READABLE; + } } - } - - if (infoPtr->watchMask & TCL_READABLE) { - if (WaitForRead(infoPtr, 0) >= 0) { - if (infoPtr->readFlags & CONSOLE_EOF) { + else { + AcquireSRWLockShared(&handleInfoPtr->lock); + if (chanInfoPtr->watchMask & TCL_READABLE + && RingBufferLength(&handleInfoPtr->buffer)) { mask = TCL_READABLE; - } else { - mask |= TCL_READABLE; } + else if (RingBufferFreeSpace(&handleInfoPtr->buffer)) { + /* Generate write event space available */ + mask = TCL_WRITABLE; + } + ReleaseSRWLockShared(&handleInfoPtr->lock); + } + if (mask) { + Tcl_NotifyChannel(chanInfoPtr->channel, mask); } } + /* Remove the reference to the channel from event record */ + if (chanInfoPtr->numRefs > 1) { + chanInfoPtr->numRefs -= 1; + freeChannel = 0; + } + else { + assert(chanInfoPtr->channel == NULL); + freeChannel = 1; + ckfree(chanInfoPtr); + } + ReleaseSRWLockShared(&gConsoleLock); - /* - * Inform the channel of the events. - */ + if (freeChannel) + ckfree(chanInfoPtr); - Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask & mask); return 1; } @@ -928,39 +1305,39 @@ ConsoleEventProc( static void ConsoleWatchProc( ClientData instanceData, /* Console state. */ - int mask) /* What events to watch for, OR-ed combination + int permissions) /* What events to watch for, OR-ed combination * of TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { - ConsoleInfo **nextPtrPtr, *ptr; - ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData; - int oldMask = infoPtr->watchMask; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ConsoleChannelInfo **nextPtrPtr, *ptr; + ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; + int oldMask = chanInfoPtr->watchMask; /* * Since most of the work is handled by the background threads, we just * need to update the watchMask and then force the notifier to poll once. */ - infoPtr->watchMask = mask & infoPtr->validMask; - if (infoPtr->watchMask) { + chanInfoPtr->watchMask = permissions & chanInfoPtr->permissions; + if (chanInfoPtr->watchMask) { Tcl_Time blockTime = { 0, 0 }; if (!oldMask) { - infoPtr->nextPtr = tsdPtr->firstConsolePtr; - tsdPtr->firstConsolePtr = infoPtr; + /* Add to list of watched channels */ + AcquireSRWLockExclusive(&gConsoleLock); + chanInfoPtr->nextWatchingChannelPtr = gWatchingChannelList; + gWatchingChannelList = chanInfoPtr; + ReleaseSRWLockExclusive(&gConsoleLock); } Tcl_SetMaxBlockTime(&blockTime); } else if (oldMask) { - /* - * Remove the console from the list of watched consoles. - */ + /* Remove from list of watched channels */ - for (nextPtrPtr = &(tsdPtr->firstConsolePtr), ptr = *nextPtrPtr; + for (nextPtrPtr = &gWatchingChannelList, ptr = *nextPtrPtr; ptr != NULL; - nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) { - if (infoPtr == ptr) { - *nextPtrPtr = ptr->nextPtr; + nextPtrPtr = &ptr->nextWatchingChannelPtr, ptr = *nextPtrPtr) { + if (chanInfoPtr == ptr) { + *nextPtrPtr = ptr->nextWatchingChannelPtr; break; } } @@ -991,12 +1368,13 @@ ConsoleGetHandleProc( TCL_UNUSED(int) /*direction*/, ClientData *handlePtr) /* Where to store the handle. */ { - ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData; + ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; - *handlePtr = infoPtr->handle; + *handlePtr = chanInfoPtr->handle; return TCL_OK; } +#ifdef OBSOLETE /* *---------------------------------------------------------------------- * @@ -1020,7 +1398,7 @@ ConsoleGetHandleProc( static int WaitForRead( - ConsoleInfo *infoPtr, /* Console state. */ + ConsoleChannelInfo *infoPtr, /* Console state. */ int blocking) /* Indicates whether call should be blocking * or not. */ { @@ -1100,6 +1478,7 @@ WaitForRead( TclPipeThreadSignal(&threadInfo->TI); } } +#endif /* *---------------------------------------------------------------------- @@ -1110,12 +1489,10 @@ WaitForRead( * available on a console. * * Results: - * None. + * Always 0. * * Side effects: - * Signals the main thread when input become available. May cause the - * main thread to wake up by posting a message. May one line from the - * console for each wait operation. + * Signals the main thread when input become available. * *---------------------------------------------------------------------- */ @@ -1124,76 +1501,147 @@ static DWORD WINAPI ConsoleReaderThread( LPVOID arg) { - TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg; - ConsoleInfo *infoPtr = NULL; /* access info only after success init/wait */ - HANDLE *handle = NULL; - ConsoleThreadInfo *threadInfo = NULL; - int done = 0; + ConsoleHandleInfo *handleInfoPtr = (ConsoleHandleInfo *) arg; + ConsoleHandleInfo **iterator; + BOOL success; + char inputChars[200]; /* Temporary buffer */ + RingSizeT inputLen = 0; + RingSizeT inputOffset = 0; - while (!done) { - /* - * Wait for the main thread to signal before attempting to read. - */ + /* + * Keep looping until one of the following happens. + * + * - there are not more channels listening on the console + * - the console handle has been closed + * + * On each iteration, + * - if the channel buffer is full, wait for some channel reader to read + * - if there is data in our input buffer copy it to the channel buffer + * - get more data from the console + */ + + /* This thread is holding a reference so pointer is safe */ + AcquireSRWLockExclusive(&handleInfoPtr->lock); - if (!TclPipeThreadWaitForSignal(&pipeTI)) { - /* exit */ + while (1) { + + if (handleInfoPtr->numRefs == 1) { + /* Sole reference. That's this thread. Exit since no one clients */ break; } - if (!infoPtr) { - infoPtr = (ConsoleInfo *)pipeTI->clientData; - handle = (HANDLE *)infoPtr->handle; - threadInfo = &infoPtr->reader; - } + if (RingBufferFreeSpace(&handleInfoPtr->buffer) == 0) { + /* No room in buffer. Awaken any reader channels */ + WakeConditionVariable(&handleInfoPtr->interpThreadCV); + /* XXX - does not wake up fileevent channels! */ + + /* Release lock and wait for room */ + success = SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV, + &handleInfoPtr->lock, + INFINITE, + 0); + /* Note: lock has been acquired again! */ + + if (!success && GetLastError() != ERROR_TIMEOUT) { + /* TODO - what can be done? Should not happen */ + /* For now keep going */ + } + continue; /* Restart loop so we can check for exit conditions */ + } /* - * Look for data on the console, but first ignore any events that are - * not KEY_EVENTs. + * The shared buffer now has room. If we had any leftover from last + * read, store that. */ + if (inputLen > 0) { + RingSizeT nStored; + HANDLE consoleHandle; + ConsoleChannelInfo *chanInfoPtr; + + nStored = RingBufferIn(&handleInfoPtr->buffer, + inputOffset + inputChars, + inputLen - inputOffset, + 1); + inputOffset += nStored; + if (inputOffset == inputLen) { + /* Temp buffer now empty */ + inputOffset = 0; + inputLen = 0; + } + /* Wake up any threads waiting synchronously. */ + WakeConditionVariable(&handleInfoPtr->interpThreadCV); - if (ReadConsoleBytes(handle, infoPtr->buffer, CONSOLE_BUFFER_SIZE, - (LPDWORD) &infoPtr->bytesRead) != FALSE) { /* - * Data was stored in the buffer. + * Wake up all channels registered for file events. Note in + * order to follow the locking hierarchy, we need to release + * handleInfoPtr->lock before acquiring gConsoleLock and + * relock it. */ - - infoPtr->readFlags |= CONSOLE_BUFFERED; - } else { - DWORD err = GetLastError(); - - if (err == (DWORD) EOF) { - infoPtr->readFlags = CONSOLE_EOF; + consoleHandle = handleInfoPtr->console; + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + AcquireSRWLockShared(&gConsoleLock); /* Shared-read lock */ + for (chanInfoPtr = gWatchingChannelList; chanInfoPtr; + chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) { + /* + * Notify channels interested in our handle AND that have + * a thread attached. + * No lock needed for chanInfoPtr. See ConsoleChannelInfo. + */ + if (chanInfoPtr->handle == consoleHandle + && chanInfoPtr->threadId != NULL) { + Tcl_ThreadAlert(chanInfoPtr->threadId); + } } - done = 1; + ReleaseSRWLockShared(&gConsoleLock); + AcquireSRWLockExclusive(&handleInfoPtr->lock); + continue; /* Restart loop */ } /* - * Signal the main thread by signalling the readable event and then - * waking up the notifier thread. + * Need to go get more data from console. We only store the last + * error. It is up to channel handlers to decide whether to close or + * what to do. */ + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + handleInfoPtr->lastError = + ReadConsoleChars(handleInfoPtr->console, + (WCHAR *)inputChars, + sizeof(inputChars) / sizeof(WCHAR), + &inputLen); + inputLen *= sizeof(WCHAR); + AcquireSRWLockExclusive(&handleInfoPtr->lock); + } - SetEvent(threadInfo->readyEvent); - - /* - * Alert the foreground thread. Note that we need to treat this like a - * critical section so the foreground thread does not terminate this - * thread while we are holding a mutex in the notifier code. - */ + /* + * Exiting: + * - remove the console from global list + * - close the handle if still valid + * - release the structure + */ + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + AcquireSRWLockExclusive(&gConsoleLock); /* Modifying - exclusive lock */ + for (iterator = &gConsoleHandleInfoList; *iterator; + iterator = &(*iterator)->nextPtr) { + if (*iterator == handleInfoPtr) { + *iterator = handleInfoPtr->nextPtr; + break; + } + } + ReleaseSRWLockExclusive(&gConsoleLock); - Tcl_MutexLock(&consoleMutex); - if (infoPtr->threadId != NULL) { - /* - * TIP #218. When in flight ignore the event, no one will receive - * it anyway. - */ + /* No need for relocking - no other thread should have access to it now */ + RingBufferClear(&handleInfoPtr->buffer); - Tcl_ThreadAlert(infoPtr->threadId); - } - Tcl_MutexUnlock(&consoleMutex); + if (handleInfoPtr->console) { + SetConsoleMode(handleInfoPtr->console, handleInfoPtr->initMode); } + /* + * NOTE: we do not call CloseHandle(handleInfoPtr->console) + * As per the GetStdHandle documentation, it need not be closed. + * TODO - what about when application closes and re-opens? - Test + */ - /* Worker exit, so inform the main thread or free TI-structure (if owned) */ - TclPipeThreadExit(&pipeTI); + ckfree(handleInfoPtr); return 0; } @@ -1210,89 +1658,262 @@ ConsoleReaderThread( * Always returns 0. * * Side effects: - - * Signals the main thread when an output operation is completed. May - * cause the main thread to wake up by posting a message. + * Signals the main thread when an output operation is completed. * *---------------------------------------------------------------------- */ - static DWORD WINAPI -ConsoleWriterThread( - LPVOID arg) +ConsoleWriterThread(LPVOID arg) { - TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg; - ConsoleInfo *infoPtr = NULL; /* access info only after success init/wait */ - HANDLE *handle = NULL; - ConsoleThreadInfo *threadInfo = NULL; - DWORD count, toWrite; - char *buf; - int done = 0; - - while (!done) { - /* - * Wait for the main thread to signal before attempting to write. - */ - if (!TclPipeThreadWaitForSignal(&pipeTI)) { - /* exit */ - break; - } - if (!infoPtr) { - infoPtr = (ConsoleInfo *)pipeTI->clientData; - handle = (HANDLE *)infoPtr->handle; - threadInfo = &infoPtr->writer; - } + ConsoleHandleInfo *handleInfoPtr = (ConsoleHandleInfo *) arg; + ConsoleHandleInfo **iterator; + ConsoleChannelInfo *chanInfoPtr = NULL; + BOOL success; + char buffer[4000]; + RingSizeT length; + + /* + * Keep looping until one of the following happens. + * + * - there are not more channels listening on the console + * - the console handle has been closed + * + * On each iteration, + * - if the channel buffer is empty, wait for some channel writer to write + * - if there is data in our buffer, write it to the console + */ - buf = infoPtr->writeBuf; - toWrite = infoPtr->toWrite; + /* This thread is holding a reference so pointer is safe */ + AcquireSRWLockExclusive(&handleInfoPtr->lock); + while (1) { + /* handleInfoPtr->lock must be held on entry to loop */ + + int offset; + HANDLE consoleHandle; /* - * Loop until all of the bytes are written or an error occurs. + * Sadly, we need to do another copy because do not want to hold + * a lock on handleInfoPtr->buffer while calling WriteConsole as that + * might block. Also, we only want to copy an integral number of + * WCHAR's, i.e. even number of chars so do some length checks up + * front. */ - - while (toWrite > 0) { - if (WriteConsoleBytes(handle, buf, (DWORD) toWrite, - &count) == FALSE) { - infoPtr->writeError = GetLastError(); - done = 1; + length = RingBufferLength(&handleInfoPtr->buffer); + length &= ~1; /* Copy integral number of WCHARs -> even number of bytes */ + if (length == 0) { + /* No data to write */ + if (handleInfoPtr->numRefs == 1) { + /* + * Sole reference. That's this thread. Exit since no clients + * and no buffered output. + */ break; } - toWrite -= count; - buf += count; + /* Wake up any threads waiting synchronously. */ + WakeConditionVariable(&handleInfoPtr->interpThreadCV); + success = SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV, + &handleInfoPtr->lock, + INFINITE, + 0); + /* Note: lock has been acquired again! */ + if (!success && GetLastError() != ERROR_TIMEOUT) { + /* TODO - what can be done? Should not happen */ + /* For now keep going */ + } + continue; } - /* - * Signal the main thread by signalling the writable event and then - * waking up the notifier thread. - */ - - SetEvent(threadInfo->readyEvent); + /* We have data to write */ + if (length > (sizeof(buffer) / sizeof(buffer[0]))) { + length = sizeof(buffer); + } + /* No need to check result, we already checked length bytes available */ + RingBufferOut(&handleInfoPtr->buffer, buffer, length, 0); + + WakeConditionVariable(&handleInfoPtr->interpThreadCV); + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + offset = 0; + while (length > 0) { + RingSizeT numWChars = length / sizeof(WCHAR); + DWORD status; + status = WriteConsoleChars( + handleInfoPtr->console, (WCHAR *) (offset + buffer) , numWChars, &numWChars); + if (status != 0) { + /* Only overwrite if no previous error */ + if (handleInfoPtr->lastError == 0) { + handleInfoPtr->lastError = status; + } + /* Assume this write is done but keep looping in case + * it is a transient error. Not sure just closing handle + * and exiting thread is a good idea. + */ + break; + } + length -= numWChars * sizeof(WCHAR); + offset += numWChars * sizeof(WCHAR); + } /* - * Alert the foreground thread. Note that we need to treat this like a - * critical section so the foreground thread does not terminate this - * thread while we are holding a mutex in the notifier code. + * Wake up all channels registered for file events. Note in + * order to follow the locking hierarchy, we need to release + * handleInfoPtr->lock before acquiring gConsoleLock and + * relock it. */ - - Tcl_MutexLock(&consoleMutex); - if (infoPtr->threadId != NULL) { + /* Wake up any threads waiting synchronously. */ + WakeConditionVariable(&handleInfoPtr->interpThreadCV); + AcquireSRWLockShared(&gConsoleLock); /* Shared-read lock */ + consoleHandle = handleInfoPtr->console; + for (chanInfoPtr = gWatchingChannelList; chanInfoPtr; + chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) { /* - * TIP #218. When in flight ignore the event, no one will receive - * it anyway. + * Notify channels interested in our handle AND that have + * a thread attached. + * No lock needed for chanInfoPtr. See ConsoleChannelInfo. */ + if (chanInfoPtr->handle == consoleHandle + && chanInfoPtr->threadId != NULL) { + Tcl_ThreadAlert(chanInfoPtr->threadId); + } + } + ReleaseSRWLockShared(&gConsoleLock); + AcquireSRWLockExclusive(&handleInfoPtr->lock); + } - Tcl_ThreadAlert(infoPtr->threadId); + /* + * Exiting: + * - remove the console from global list + * - close the handle if still valid + * - release the structure + */ + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + AcquireSRWLockExclusive(&gConsoleLock); /* Modifying - exclusive lock */ + for (iterator = &gConsoleHandleInfoList; *iterator; + iterator = &(*iterator)->nextPtr) { + if (*iterator == handleInfoPtr) { + *iterator = handleInfoPtr->nextPtr; + break; } - Tcl_MutexUnlock(&consoleMutex); } + ReleaseSRWLockExclusive(&gConsoleLock); + + RingBufferClear(&handleInfoPtr->buffer); + + /* + * NOTE: we do not call CloseHandle(handleInfoPtr->console) + * As per the GetStdHandle documentation, it need not be closed. + * TODO - what about when application closes and re-opens? - Test + */ - /* Worker exit, so inform the main thread or free TI-structure (if owned) */ - TclPipeThreadExit(&pipeTI); + ckfree(handleInfoPtr); return 0; } /* + *------------------------------------------------------------------------ + * + * AllocateConsoleHandleInfo -- + * + * Allocates a ConsoleHandleInfo for the passed console handle. As + * a side effect starts a console thread to handle i/o on the handle. + * + * Important: Caller must be holding an EXCLUSIVE lock on gConsoleLock + * when calling this function. The lock continues to be held on return. + * + * Results: + * Pointer to an unlocked ConsoleHandleInfo structure. The reference + * count on the structure is 1. This corresponds to the common reference + * from the console thread and the gConsoleHandleInfoList. Returns NULL + * on error. + * + * Side effects: + * A console reader or writer thread is started. The returned structure + * is placed on the active console handler list gConsoleHandleInfoList. + * + *------------------------------------------------------------------------ + */ +static ConsoleHandleInfo * +AllocateConsoleHandleInfo( + HANDLE consoleHandle, + int permissions) /* TCL_READABLE or TCL_WRITABLE */ +{ + ConsoleHandleInfo *handleInfoPtr; + DWORD consoleMode; + + + handleInfoPtr = (ConsoleHandleInfo *)ckalloc(sizeof(*handleInfoPtr)); + handleInfoPtr->console = consoleHandle; + InitializeSRWLock(&handleInfoPtr->lock); + InitializeConditionVariable(&handleInfoPtr->consoleThreadCV); + InitializeConditionVariable(&handleInfoPtr->interpThreadCV); + RingBufferInit(&handleInfoPtr->buffer, CONSOLE_BUFFER_SIZE); + handleInfoPtr->lastError = 0; + handleInfoPtr->permissions = permissions; + handleInfoPtr->numRefs = 1; /* See function header */ + if (permissions == TCL_READABLE) { + GetConsoleMode(consoleHandle, &handleInfoPtr->initMode); + consoleMode = handleInfoPtr->initMode; + consoleMode &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT); + consoleMode |= ENABLE_LINE_INPUT; + SetConsoleMode(consoleHandle, consoleMode); + } + handleInfoPtr->consoleThread = CreateThread( + NULL, /* default security descriptor */ + 8192, /* Stack size - will get rounded up to allocation granularity */ + permissions == TCL_READABLE ? ConsoleReaderThread : ConsoleWriterThread, + handleInfoPtr, /* Pass to thread */ + 0, /* Flags - no special cases */ + NULL); /* Don't care about thread id */ + if (handleInfoPtr->consoleThread == NULL) { + /* Note - SRWLock and condition variables do not need finalization */ + RingBufferClear(&handleInfoPtr->buffer); + ckfree(handleInfoPtr); + return NULL; + } + + /* Chain onto global list */ + handleInfoPtr->nextPtr = gConsoleHandleInfoList; + gConsoleHandleInfoList = handleInfoPtr; + + return handleInfoPtr; +} + +/* + *------------------------------------------------------------------------ + * + * FindConsoleInfo -- + * + * Finds the ConsoleHandleInfo record for a given ConsoleChannelInfo. + * The found record must match the console handle. It is the caller's + * responsibility to check the permissions (read/write) in the returned + * ConsoleHandleInfo match permissions in chanInfoPtr. This function does + * not check that. + * + * Important: Caller must be holding an shared or exclusive lock on + * gConsoleMutex. That ensures the returned pointer stays valid on + * return without risk of deallocation by other threads. + * + * Results: + * Pointer to the found ConsoleHandleInfo or NULL if not found + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ +static ConsoleHandleInfo * +FindConsoleInfo(const ConsoleChannelInfo *chanInfoPtr) +{ + ConsoleHandleInfo *handleInfoPtr; + for (handleInfoPtr = gConsoleHandleInfoList; handleInfoPtr; handleInfoPtr = handleInfoPtr->nextPtr) { + if (handleInfoPtr->console == chanInfoPtr->handle) { + return handleInfoPtr; + } + } + return NULL; +} + +/* *---------------------------------------------------------------------- * * TclWinOpenConsoleChannel -- @@ -1309,33 +1930,30 @@ ConsoleWriterThread( * *---------------------------------------------------------------------- */ - Tcl_Channel TclWinOpenConsoleChannel( HANDLE handle, char *channelName, int permissions) { - char encoding[4 + TCL_INTEGER_SPACE]; - ConsoleInfo *infoPtr; - DWORD modes; + ConsoleChannelInfo *chanInfoPtr; + ConsoleHandleInfo *handleInfoPtr; - ConsoleInit(); - - /* - * See if a channel with this handle already exists. - */ + /* A console handle can either be input or output, not both */ + if (permissions != TCL_READABLE && permissions != TCL_WRITABLE) { + return NULL; + } - infoPtr = (ConsoleInfo *)ckalloc(sizeof(ConsoleInfo)); - memset(infoPtr, 0, sizeof(ConsoleInfo)); + ConsoleInit(); - infoPtr->validMask = permissions; - infoPtr->handle = handle; - infoPtr->channel = (Tcl_Channel) NULL; + chanInfoPtr = (ConsoleChannelInfo *)ckalloc(sizeof(*chanInfoPtr)); + memset(chanInfoPtr, 0, sizeof(*chanInfoPtr)); - wsprintfA(encoding, "cp%d", GetConsoleCP()); + chanInfoPtr->permissions = permissions; + chanInfoPtr->handle = handle; + chanInfoPtr->channel = (Tcl_Channel) NULL; - infoPtr->threadId = Tcl_GetCurrentThread(); + chanInfoPtr->threadId = Tcl_GetCurrentThread(); /* * Use the pointer for the name of the result channel. This keeps the @@ -1343,10 +1961,7 @@ TclWinOpenConsoleChannel( * for instance). */ - sprintf(channelName, "file%" TCL_Z_MODIFIER "x", (size_t) infoPtr); - - infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName, - infoPtr, permissions); + sprintf(channelName, "file%" TCL_Z_MODIFIER "x", (size_t) chanInfoPtr); if (permissions & TCL_READABLE) { /* @@ -1355,38 +1970,78 @@ TclWinOpenConsoleChannel( * we only want to catch when complete lines are ready for reading. */ - infoPtr->flags |= CONSOLE_READ_OPS; - GetConsoleMode(infoPtr->handle, &infoPtr->initMode); - modes = infoPtr->initMode; - modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT); - modes |= ENABLE_LINE_INPUT; - SetConsoleMode(infoPtr->handle, modes); - - infoPtr->reader.readyEvent = CreateEventW(NULL, TRUE, TRUE, NULL); - infoPtr->reader.thread = CreateThread(NULL, 256, ConsoleReaderThread, - TclPipeThreadCreateTI(&infoPtr->reader.TI, infoPtr, - infoPtr->reader.readyEvent), 0, NULL); + chanInfoPtr->flags |= CONSOLE_READ_OPS; + GetConsoleMode(handle, &chanInfoPtr->initMode); + +#ifdef OBSOLETE + /* Why was priority being set on console input? Code smell */ SetThreadPriority(infoPtr->reader.thread, THREAD_PRIORITY_HIGHEST); +#endif + } + else { + /* Already checked permissions is WRITABLE if not READABLE */ + /* TODO - enable ansi escape processing? */ } - if (permissions & TCL_WRITABLE) { + /* + * Global lock but that's ok. See comments top of file. Allocations + * will happen only a few times in the life of a process and that too + * generally at start up where only one thread is active. + */ + AcquireSRWLockExclusive(&gConsoleLock); /*Allocate needs exclusive lock */ - infoPtr->writer.readyEvent = CreateEventW(NULL, TRUE, TRUE, NULL); - infoPtr->writer.thread = CreateThread(NULL, 256, ConsoleWriterThread, - TclPipeThreadCreateTI(&infoPtr->writer.TI, infoPtr, - infoPtr->writer.readyEvent), 0, NULL); - SetThreadPriority(infoPtr->writer.thread, THREAD_PRIORITY_HIGHEST); + handleInfoPtr = FindConsoleInfo(chanInfoPtr); + if (handleInfoPtr == NULL) { + /* Not found. Allocate one */ + handleInfoPtr = AllocateConsoleHandleInfo(handle, permissions); + } + else { + /* Found. Its direction (read/write) better be the same */ + if (handleInfoPtr->permissions != permissions) { + handleInfoPtr = NULL; + } + } + + if (handleInfoPtr == NULL) { + ReleaseSRWLockExclusive(&gConsoleLock); + if (permissions == TCL_READABLE) { + SetConsoleMode(handle, chanInfoPtr->initMode); + } + ckfree(chanInfoPtr); + return NULL; } /* + * There is effectively a reference to this structure from the Tcl + * channel subsystem. So record that. This reference will be dropped + * when the Tcl channel is closed. + */ + chanInfoPtr->numRefs = 1; + + /* + * Need to keep track of number of referencing channels for closing. + * The pointer is safe since there is a reference held to it from + * gConsoleHandleInfoList but still need to lock the structure itself + */ + AcquireSRWLockExclusive(&handleInfoPtr->lock); + handleInfoPtr->numRefs += 1; + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + + ReleaseSRWLockExclusive(&gConsoleLock); + + /* Note Tcl_CreateChannel never fails other than panic on error */ + chanInfoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName, + chanInfoPtr, permissions); + + /* * Files have default translation of AUTO and ^Z eof char, which means * that a ^Z will be accepted as EOF when reading. */ - Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); - Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); - Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "utf-16"); - return infoPtr->channel; + Tcl_SetChannelOption(NULL, chanInfoPtr->channel, "-translation", "auto"); + Tcl_SetChannelOption(NULL, chanInfoPtr->channel, "-eofchar", "\032 {}"); + Tcl_SetChannelOption(NULL, chanInfoPtr->channel, "-encoding", "utf-16"); + return chanInfoPtr->channel; } /* @@ -1410,33 +2065,16 @@ ConsoleThreadActionProc( ClientData instanceData, int action) { - ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData; - - /* - * We do not access firstConsolePtr in the thread structures. This is not - * for all serials managed by the thread, but only those we are watching. - * Removal of the filevent handlers before transfer thus takes care of - * this structure. - */ + ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; - Tcl_MutexLock(&consoleMutex); + /* No need for any locks as no other thread will be writing to it */ if (action == TCL_CHANNEL_THREAD_INSERT) { - /* - * We can't copy the thread information from the channel when the - * channel is created. At this time the channel back pointer has not - * been set yet. However in that case the threadId has already been - * set by TclpCreateCommandChannel itself, so the structure is still - * good. - */ - - ConsoleInit(); - if (infoPtr->channel != NULL) { - infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel); - } - } else { - infoPtr->threadId = NULL; + ConsoleInit(); /* Needed to set up event source handlers for this thread */ + chanInfoPtr->threadId = Tcl_GetCurrentThread(); + } + else { + chanInfoPtr->threadId = NULL; } - Tcl_MutexUnlock(&consoleMutex); } /* @@ -1456,7 +2094,6 @@ ConsoleThreadActionProc( * *---------------------------------------------------------------------- */ - static int ConsoleSetOptionProc( ClientData instanceData, /* File state. */ @@ -1464,7 +2101,7 @@ ConsoleSetOptionProc( const char *optionName, /* Which option to set? */ const char *value) /* New value for option. */ { - ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData; + ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; int len = strlen(optionName); int vlen = strlen(value); @@ -1472,11 +2109,11 @@ ConsoleSetOptionProc( * Option -inputmode normal|password|raw */ - if ((infoPtr->flags & CONSOLE_READ_OPS) && (len > 1) && + if ((chanInfoPtr->flags & CONSOLE_READ_OPS) && (len > 1) && (strncmp(optionName, "-inputmode", len) == 0)) { DWORD mode; - if (GetConsoleMode(infoPtr->handle, &mode) == 0) { + if (GetConsoleMode(chanInfoPtr->handle, &mode) == 0) { Tcl_WinConvertError(GetLastError()); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1496,8 +2133,7 @@ ConsoleSetOptionProc( /* * Reset to the initial mode, whatever that is. */ - - mode = infoPtr->initMode; + mode = chanInfoPtr->initMode; } else { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1508,7 +2144,7 @@ ConsoleSetOptionProc( } return TCL_ERROR; } - if (SetConsoleMode(infoPtr->handle, mode) == 0) { + if (SetConsoleMode(chanInfoPtr->handle, mode) == 0) { Tcl_WinConvertError(GetLastError()); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1518,19 +2154,10 @@ ConsoleSetOptionProc( return TCL_ERROR; } - /* - * If we've changed the mode from default, schedule a reset later. - */ - - if (mode == infoPtr->initMode) { - infoPtr->flags &= ~CONSOLE_RESET; - } else { - infoPtr->flags |= CONSOLE_RESET; - } return TCL_OK; } - if (infoPtr->flags & CONSOLE_READ_OPS) { + if (chanInfoPtr->flags & CONSOLE_READ_OPS) { return Tcl_BadChannelOption(interp, optionName, "inputmode"); } else { return Tcl_BadChannelOption(interp, optionName, ""); @@ -1562,7 +2189,7 @@ ConsoleGetOptionProc( const char *optionName, /* Option to get. */ Tcl_DString *dsPtr) /* Where to store value(s). */ { - ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData; + ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; int valid = 0; /* Flag if valid option parsed. */ unsigned int len; char buf[TCL_INTEGER_SPACE]; @@ -1580,7 +2207,7 @@ ConsoleGetOptionProc( * represents what almost all scripts really want to know. */ - if (infoPtr->flags & CONSOLE_READ_OPS) { + if (chanInfoPtr->flags & CONSOLE_READ_OPS) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-inputmode"); } @@ -1588,7 +2215,7 @@ ConsoleGetOptionProc( DWORD mode; valid = 1; - if (GetConsoleMode(infoPtr->handle, &mode) == 0) { + if (GetConsoleMode(chanInfoPtr->handle, &mode) == 0) { Tcl_WinConvertError(GetLastError()); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1619,7 +2246,7 @@ ConsoleGetOptionProc( CONSOLE_SCREEN_BUFFER_INFO consoleInfo; valid = 1; - if (!GetConsoleScreenBufferInfo(infoPtr->handle, &consoleInfo)) { + if (!GetConsoleScreenBufferInfo(chanInfoPtr->handle, &consoleInfo)) { Tcl_WinConvertError(GetLastError()); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1639,7 +2266,7 @@ ConsoleGetOptionProc( if (valid) { return TCL_OK; } - if (infoPtr->flags & CONSOLE_READ_OPS) { + if (chanInfoPtr->flags & CONSOLE_READ_OPS) { return Tcl_BadChannelOption(interp, optionName, "inputmode winsize"); } else { return Tcl_BadChannelOption(interp, optionName, ""); -- cgit v0.12 From 5f73d7d78e86e4238433c90d99e0d346c0fc6728 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 28 Jun 2022 15:42:14 +0000 Subject: Finishing touches. Remove obsolete code --- win/tclWinConsole.c | 401 +++++++++++++++++++++++----------------------------- 1 file changed, 177 insertions(+), 224 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 14cc6e5..08e7e56 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -10,7 +10,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#define TCL_CONSOLE_DEBUG #ifdef TCL_CONSOLE_DEBUG #undef NDEBUG /* Enable asserts */ #endif @@ -55,7 +54,14 @@ static int initialized = 0; -#define CONSOLE_BUFFER_SIZE 8000 // TODO - must be at least 2 :-) +#ifdef TCL_CONSOLE_DEBUG +#ifndef CONSOLE_BUFFER_SIZE +/* Force tiny to stress synchronization. Must be at least sizeof(WCHAR) :-) */ +#define CONSOLE_BUFFER_SIZE 10 +#endif +#else +#define CONSOLE_BUFFER_SIZE 4000 /* In bytes */ +#endif /* * Ring buffer for storing data. Actual data is from bufPtr[start]:bufPtr[size-1] @@ -227,9 +233,7 @@ static ConsoleHandleInfo *AllocateConsoleHandleInfo(HANDLE consoleHandle, static ConsoleHandleInfo *FindConsoleInfo(const ConsoleChannelInfo *); static DWORD WINAPI ConsoleReaderThread(LPVOID arg); static DWORD WINAPI ConsoleWriterThread(LPVOID arg); -#ifdef OBSOLETE -static int WaitForRead(ConsoleChannelInfo *infoPtr, int blocking); -#endif +static void NudgeWatchers(HANDLE consoleHandle); /* * Static data. @@ -251,10 +255,6 @@ static Tcl_ThreadDataKey dataKey; * likely not only complicate implementation but be slower due to multiple * locks being held. Note console channels also differ from other Tcl * channel types in that the channel<->OS descriptor mapping is not one-to-one. - * - * The gConsoleLock locks around access to the initialized variable, and it - * is used to protect background threads from being terminated while they - * are using APIs that hold locks. TBD - is this still true? */ SRWLOCK gConsoleLock; @@ -374,7 +374,6 @@ RingBufferIn( ) { RingSizeT freeSpace; - RingSizeT endSpace; RINGBUFFER_ASSERT(ringPtr); @@ -387,23 +386,25 @@ RingBufferIn( srcLen = freeSpace; } - /* Copy as much as possible to the tail */ if (ringPtr->capacity - ringPtr->start > ringPtr->length) { /* There is room at the back */ RingSizeT endSpaceStart = ringPtr->start + ringPtr->length; - endSpace = ringPtr->capacity - endSpaceStart; - if (endSpace > srcLen) { - endSpace = srcLen; + RingSizeT endSpace = ringPtr->capacity - endSpaceStart; + if (endSpace >= srcLen) { + /* Everything fits at the back */ + memmove(endSpaceStart + ringPtr->bufPtr, srcPtr, srcLen); + } + else { + /* srcLen > endSpace */ + memmove(endSpaceStart + ringPtr->bufPtr, srcPtr, endSpace); + memmove(ringPtr->bufPtr, endSpace + srcPtr, srcLen - endSpace); } - memmove(endSpaceStart + ringPtr->bufPtr, srcPtr, endSpace); } else { - endSpace = 0; - } - - /* Wrap around any left over data. Have already copied endSpace bytes */ - if (srcLen > endSpace) { - memmove(ringPtr->bufPtr, endSpace + srcPtr, srcLen - endSpace); + /* No room at the back. Existing data wrap to front. */ + RingSizeT wrapLen = + ringPtr->start + ringPtr->length - ringPtr->capacity; + memmove(wrapLen + ringPtr->bufPtr, srcPtr, srcLen); } ringPtr->length += srcLen; @@ -716,6 +717,43 @@ ProcExitHandler( } /* + *------------------------------------------------------------------------ + * + * NudgeWatchers -- + * + * Wakes up all threads which have file event watchers on the passed + * console handle. + * + * The function locks and releases gConsoleLock. + * Caller must not be holding locks that will violate lock hierarchy. + * + * Results: + * None. + * + * Side effects: + * As above. + *------------------------------------------------------------------------ + */ +void NudgeWatchers (HANDLE consoleHandle) +{ + ConsoleChannelInfo *chanInfoPtr; + AcquireSRWLockShared(&gConsoleLock); /* Shared-read lock */ + for (chanInfoPtr = gWatchingChannelList; chanInfoPtr; + chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) { + /* + * Notify channels interested in our handle AND that have + * a thread attached. + * No lock needed for chanInfoPtr. See ConsoleChannelInfo. + */ + if (chanInfoPtr->handle == consoleHandle + && chanInfoPtr->threadId != NULL) { + Tcl_ThreadAlert(chanInfoPtr->threadId); + } + } + ReleaseSRWLockShared(&gConsoleLock); +} + +/* *---------------------------------------------------------------------- * * ConsoleSetupProc -- @@ -760,10 +798,12 @@ ConsoleSetupProc( if (handleInfoPtr != NULL) { AcquireSRWLockShared(&handleInfoPtr->lock); if ((chanInfoPtr->watchMask & TCL_READABLE) - && RingBufferLength(&handleInfoPtr->buffer) > 0) { + && (RingBufferLength(&handleInfoPtr->buffer) > 0 + || handleInfoPtr->lastError != ERROR_SUCCESS)) { block = 0; /* Input data available */ } else if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { + /* TCL_WRITABLE */ block = 0; /* Output space available */ } ReleaseSRWLockShared(&handleInfoPtr->lock); @@ -837,8 +877,9 @@ ConsoleCheckProc( if (handleInfoPtr != NULL) { AcquireSRWLockShared(&handleInfoPtr->lock); if ((chanInfoPtr->watchMask & TCL_READABLE) - && RingBufferLength(&handleInfoPtr->buffer) > 0) { - needEvent = 1; /* Input data available */ + && (RingBufferLength(&handleInfoPtr->buffer) > 0 + || handleInfoPtr->lastError != ERROR_SUCCESS)) { + needEvent = 1; /* Input data available or error/EOF */ } else if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { needEvent = 1; /* Output space available */ @@ -974,7 +1015,7 @@ ConsoleCloseProc( * Don't close the Win32 handle if the handle is a standard channel * during the thread exit process. Otherwise, one thread may kill the * stdio of another. TODO - an explicit close in script will still close - * it. + * it. Is that desired behavior? */ if (!TclInThreadExit() || ((GetStdHandle(STD_INPUT_HANDLE) != chanInfoPtr->handle) @@ -1050,8 +1091,8 @@ ConsoleInputProc( /* * No data available. * - If an error was recorded, generate that and reset it. - * - If EOF, indicate as much. TODO - can console thread still be - * running in that case? + * - If EOF, indicate as much. It is up to application to close + * the channel. * - Otherwise, if non-blocking return EAGAIN or wait for more data. */ if (handleInfoPtr->lastError != 0) { @@ -1374,112 +1415,6 @@ ConsoleGetHandleProc( return TCL_OK; } -#ifdef OBSOLETE -/* - *---------------------------------------------------------------------- - * - * WaitForRead -- - * - * Wait until some data is available, the console is at EOF or the reader - * thread is blocked waiting for data (if the channel is in non-blocking - * mode). - * - * Results: - * Returns 1 if console is readable. Returns 0 if there is no data on the - * console, but there is buffered data. Returns -1 if an error occurred. - * If an error occurred, the threads may not be synchronized. - * - * Side effects: - * Updates the shared state flags. If no error occurred, the reader - * thread is blocked waiting for a signal from the main thread. - * - *---------------------------------------------------------------------- - */ - -static int -WaitForRead( - ConsoleChannelInfo *infoPtr, /* Console state. */ - int blocking) /* Indicates whether call should be blocking - * or not. */ -{ - DWORD timeout, count; - HANDLE *handle = (HANDLE *)infoPtr->handle; - ConsoleThreadInfo *threadInfo = &infoPtr->reader; - INPUT_RECORD input; - - while (1) { - /* - * Synchronize with the reader thread. - */ - - /* avoid blocking if pipe-thread exited */ - timeout = (!blocking || !TclPipeThreadIsAlive(&threadInfo->TI) - || TclInExit() || TclInThreadExit()) ? 0 : INFINITE; - if (WaitForSingleObject(threadInfo->readyEvent, timeout) == WAIT_TIMEOUT) { - /* - * The reader thread is blocked waiting for data and the channel - * is in non-blocking mode. - */ - - errno = EWOULDBLOCK; - return -1; - } - - /* - * At this point, the two threads are synchronized, so it is safe to - * access shared state. - */ - - /* - * If the console has hit EOF, it is always readable. - */ - - if (infoPtr->readFlags & CONSOLE_EOF) { - return 1; - } - - if (PeekConsoleInputW(handle, &input, 1, &count) == FALSE) { - /* - * Check to see if the peek failed because of EOF. - */ - - Tcl_WinConvertError(GetLastError()); - - if (errno == EOF) { - infoPtr->readFlags |= CONSOLE_EOF; - return 1; - } - - /* - * Ignore errors if there is data in the buffer. - */ - - if (infoPtr->readFlags & CONSOLE_BUFFERED) { - return 0; - } else { - return -1; - } - } - - /* - * If there is data in the buffer, the console must be readable (since - * it is a line-oriented device). - */ - - if (infoPtr->readFlags & CONSOLE_BUFFERED) { - return 1; - } - - /* - * There wasn't any data available, so reset the thread and try again. - */ - - ResetEvent(threadInfo->readyEvent); - TclPipeThreadSignal(&threadInfo->TI); - } -} -#endif - /* *---------------------------------------------------------------------- * @@ -1526,48 +1461,74 @@ ConsoleReaderThread( while (1) { if (handleInfoPtr->numRefs == 1) { - /* Sole reference. That's this thread. Exit since no one clients */ + /* + * Sole reference. That's this thread. Exit since no clients + * and no way for a thread to attach to a console after process + * start. + */ break; } + /* + * Cases: + * (1) The shared input buffer is full. Have to wait for an interp + * thread to read from it and make room. + * (2) The shared input buffer has room and the thread private buffer + * has data. Copy into the shared input buffer. + * (3) The channel has previously seen an error. Treat as EOF. Note + * this check is after the above so any data already available + * is passed on. + * (4) Neither buffer has data and no errors. Go get some from console. + * + * There is some duplication of code below but easier to think about + * rather than combining cases. + */ if (RingBufferFreeSpace(&handleInfoPtr->buffer) == 0) { - /* No room in buffer. Awaken any reader channels */ + /* Case (1) No room in buffer.*/ + + /* Awaken any reader channels - TODO - is this really needed? */ WakeConditionVariable(&handleInfoPtr->interpThreadCV); - /* XXX - does not wake up fileevent channels! */ /* Release lock and wait for room */ success = SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV, &handleInfoPtr->lock, INFINITE, 0); - /* Note: lock has been acquired again! */ + /* Note: lock has been reacquired */ if (!success && GetLastError() != ERROR_TIMEOUT) { /* TODO - what can be done? Should not happen */ /* For now keep going */ } - continue; /* Restart loop so we can check for exit conditions */ - } - - /* - * The shared buffer now has room. If we had any leftover from last - * read, store that. - */ - if (inputLen > 0) { - RingSizeT nStored; + } else if (inputLen > 0 || handleInfoPtr->lastError != 0) { + /* Cases (2) and (3) - require notifications to interpreters */ HANDLE consoleHandle; - ConsoleChannelInfo *chanInfoPtr; - - nStored = RingBufferIn(&handleInfoPtr->buffer, - inputOffset + inputChars, - inputLen - inputOffset, - 1); - inputOffset += nStored; - if (inputOffset == inputLen) { - /* Temp buffer now empty */ - inputOffset = 0; - inputLen = 0; + if (inputLen > 0) { + /* + * Case (2). Private buffer has data. Copy it over. + */ + RingSizeT nStored; + + assert((inputLen - inputOffset) > 0); + + nStored = RingBufferIn(&handleInfoPtr->buffer, + inputOffset + inputChars, + inputLen - inputOffset, + 1); + inputOffset += nStored; + if (inputOffset == inputLen) { + /* Temp buffer now empty */ + inputOffset = 0; + inputLen = 0; + } } + else { + /* + * Case (3). On error, nothing but inform caller and wait + * We do not want to exit until there are no client interps. + */ + } + /* Wake up any threads waiting synchronously. */ WakeConditionVariable(&handleInfoPtr->interpThreadCV); @@ -1578,38 +1539,33 @@ ConsoleReaderThread( * relock it. */ consoleHandle = handleInfoPtr->console; + /* + * Wake up all channels registered for file events. Note in + * order to follow the locking hierarchy, we cannot hold any locks + * when calling NudgeWatchers. + */ ReleaseSRWLockExclusive(&handleInfoPtr->lock); - AcquireSRWLockShared(&gConsoleLock); /* Shared-read lock */ - for (chanInfoPtr = gWatchingChannelList; chanInfoPtr; - chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) { - /* - * Notify channels interested in our handle AND that have - * a thread attached. - * No lock needed for chanInfoPtr. See ConsoleChannelInfo. - */ - if (chanInfoPtr->handle == consoleHandle - && chanInfoPtr->threadId != NULL) { - Tcl_ThreadAlert(chanInfoPtr->threadId); - } + NudgeWatchers(consoleHandle); + + AcquireSRWLockExclusive(&handleInfoPtr->lock); + } + else { + /* + * Case (4). Need to go get more data from console. We only + * store the last error. It is up to channel handlers to decide + * whether to close or what to do. + */ + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + handleInfoPtr->lastError = + ReadConsoleChars(handleInfoPtr->console, + (WCHAR *)inputChars, + sizeof(inputChars) / sizeof(WCHAR), + &inputLen); + if (handleInfoPtr->lastError == 0) { + inputLen *= sizeof(WCHAR); } - ReleaseSRWLockShared(&gConsoleLock); AcquireSRWLockExclusive(&handleInfoPtr->lock); - continue; /* Restart loop */ } - - /* - * Need to go get more data from console. We only store the last - * error. It is up to channel handlers to decide whether to close or - * what to do. - */ - ReleaseSRWLockExclusive(&handleInfoPtr->lock); - handleInfoPtr->lastError = - ReadConsoleChars(handleInfoPtr->console, - (WCHAR *)inputChars, - sizeof(inputChars) / sizeof(WCHAR), - &inputLen); - inputLen *= sizeof(WCHAR); - AcquireSRWLockExclusive(&handleInfoPtr->lock); } /* @@ -1617,6 +1573,8 @@ ConsoleReaderThread( * - remove the console from global list * - close the handle if still valid * - release the structure + * Note there is not need to check for any watchers because we only + * exit when there are no channels open to this console. */ ReleaseSRWLockExclusive(&handleInfoPtr->lock); AcquireSRWLockExclusive(&gConsoleLock); /* Modifying - exclusive lock */ @@ -1632,14 +1590,15 @@ ConsoleReaderThread( /* No need for relocking - no other thread should have access to it now */ RingBufferClear(&handleInfoPtr->buffer); - if (handleInfoPtr->console) { + if (handleInfoPtr->console + && handleInfoPtr->lastError != ERROR_INVALID_HANDLE) { SetConsoleMode(handleInfoPtr->console, handleInfoPtr->initMode); + /* + * NOTE: we do not call CloseHandle(handleInfoPtr->console) + * As per the GetStdHandle documentation, it need not be closed. + * TODO - what about when application closes and re-opens? - Test + */ } - /* - * NOTE: we do not call CloseHandle(handleInfoPtr->console) - * As per the GetStdHandle documentation, it need not be closed. - * TODO - what about when application closes and re-opens? - Test - */ ckfree(handleInfoPtr); @@ -1669,8 +1628,13 @@ ConsoleWriterThread(LPVOID arg) ConsoleHandleInfo **iterator; ConsoleChannelInfo *chanInfoPtr = NULL; BOOL success; - char buffer[4000]; - RingSizeT length; + RingSizeT numBytes; + /* + * This buffer size has no relation really with the size of the shared + * buffer. Could be bigger or smaller. Make larger as multiple threads + * could potentially be writing to it. + */ + char buffer[2*CONSOLE_BUFFER_SIZE]; /* * Keep looping until one of the following happens. @@ -1698,9 +1662,9 @@ ConsoleWriterThread(LPVOID arg) * WCHAR's, i.e. even number of chars so do some length checks up * front. */ - length = RingBufferLength(&handleInfoPtr->buffer); - length &= ~1; /* Copy integral number of WCHARs -> even number of bytes */ - if (length == 0) { + numBytes = RingBufferLength(&handleInfoPtr->buffer); + numBytes &= ~1; /* Copy integral number of WCHARs -> even number of bytes */ + if (numBytes == 0) { /* No data to write */ if (handleInfoPtr->numRefs == 1) { /* @@ -1724,20 +1688,23 @@ ConsoleWriterThread(LPVOID arg) } /* We have data to write */ - if (length > (sizeof(buffer) / sizeof(buffer[0]))) { - length = sizeof(buffer); + if (numBytes > (sizeof(buffer) / sizeof(buffer[0]))) { + numBytes = sizeof(buffer); } /* No need to check result, we already checked length bytes available */ - RingBufferOut(&handleInfoPtr->buffer, buffer, length, 0); + RingBufferOut(&handleInfoPtr->buffer, buffer, numBytes, 0); + consoleHandle = handleInfoPtr->console; WakeConditionVariable(&handleInfoPtr->interpThreadCV); ReleaseSRWLockExclusive(&handleInfoPtr->lock); offset = 0; - while (length > 0) { - RingSizeT numWChars = length / sizeof(WCHAR); + while (numBytes > 0) { + RingSizeT numWChars = numBytes / sizeof(WCHAR); DWORD status; - status = WriteConsoleChars( - handleInfoPtr->console, (WCHAR *) (offset + buffer) , numWChars, &numWChars); + status = WriteConsoleChars(handleInfoPtr->console, + (WCHAR *)(offset + buffer), + numWChars, + &numWChars); if (status != 0) { /* Only overwrite if no previous error */ if (handleInfoPtr->lastError == 0) { @@ -1749,33 +1716,19 @@ ConsoleWriterThread(LPVOID arg) */ break; } - length -= numWChars * sizeof(WCHAR); + numBytes -= numWChars * sizeof(WCHAR); offset += numWChars * sizeof(WCHAR); } + /* Wake up any threads waiting synchronously. */ + WakeConditionVariable(&handleInfoPtr->interpThreadCV); /* * Wake up all channels registered for file events. Note in - * order to follow the locking hierarchy, we need to release - * handleInfoPtr->lock before acquiring gConsoleLock and - * relock it. + * order to follow the locking hierarchy, we cannot hold any locks + * when calling NudgeWatchers. */ - /* Wake up any threads waiting synchronously. */ - WakeConditionVariable(&handleInfoPtr->interpThreadCV); - AcquireSRWLockShared(&gConsoleLock); /* Shared-read lock */ - consoleHandle = handleInfoPtr->console; - for (chanInfoPtr = gWatchingChannelList; chanInfoPtr; - chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) { - /* - * Notify channels interested in our handle AND that have - * a thread attached. - * No lock needed for chanInfoPtr. See ConsoleChannelInfo. - */ - if (chanInfoPtr->handle == consoleHandle - && chanInfoPtr->threadId != NULL) { - Tcl_ThreadAlert(chanInfoPtr->threadId); - } - } - ReleaseSRWLockShared(&gConsoleLock); + NudgeWatchers(consoleHandle); + AcquireSRWLockExclusive(&handleInfoPtr->lock); } -- cgit v0.12 From 71bdb52035482906a19b37a648b085fe8ab2fd24 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 29 Jun 2022 15:56:06 +0000 Subject: Notify other threads if one thread closes a Windows console channel --- win/tclWinConsole.c | 251 ++++++++++++++++++++++++++++++---------------------- 1 file changed, 143 insertions(+), 108 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 08e7e56..b360a17 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -60,7 +60,7 @@ static int initialized = 0; #define CONSOLE_BUFFER_SIZE 10 #endif #else -#define CONSOLE_BUFFER_SIZE 4000 /* In bytes */ +#define CONSOLE_BUFFER_SIZE 8000 /* In bytes */ #endif /* @@ -969,10 +969,26 @@ ConsoleCloseProc( ConsoleHandleInfo *handleInfoPtr; int errorCode = 0; ConsoleChannelInfo **nextPtrPtr; + int closeHandle; if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) { return EINVAL; } + /* + * Don't close the Win32 handle if the handle is a standard channel + * during the thread exit process. Otherwise, one thread may kill the + * stdio of another while exiting. Note an explicit close in script will + * still close the handle. That's historical behavior on all platforms. + */ + if (!TclInThreadExit() + || ((GetStdHandle(STD_INPUT_HANDLE) != chanInfoPtr->handle) + && (GetStdHandle(STD_OUTPUT_HANDLE) != chanInfoPtr->handle) + && (GetStdHandle(STD_ERROR_HANDLE) != chanInfoPtr->handle))) { + closeHandle = 1; + } + else { + closeHandle = 0; + } AcquireSRWLockExclusive(&gConsoleLock); @@ -994,11 +1010,15 @@ ConsoleCloseProc( AcquireSRWLockShared(&handleInfoPtr->lock); handleInfoPtr->numRefs -= 1; /* Remove reference from this channel */ + handleInfoPtr->console = INVALID_HANDLE_VALUE; /* Break the thread out of blocking console i/o */ CancelSynchronousIo(handleInfoPtr->consoleThread); - /* Wake up the console handling thread */ + /* + * Wake up the console handling thread. Note we do not explicitly + * tell it handle is closed (below). It will find out on next access + */ WakeConditionVariable(&handleInfoPtr->consoleThreadCV); ReleaseSRWLockShared(&handleInfoPtr->lock); @@ -1006,27 +1026,16 @@ ConsoleCloseProc( ReleaseSRWLockExclusive(&gConsoleLock); - chanInfoPtr->channel = NULL; + chanInfoPtr->channel = NULL; chanInfoPtr->watchMask = 0; chanInfoPtr->permissions = 0; - if (chanInfoPtr->handle) { - /* - * Don't close the Win32 handle if the handle is a standard channel - * during the thread exit process. Otherwise, one thread may kill the - * stdio of another. TODO - an explicit close in script will still close - * it. Is that desired behavior? - */ - if (!TclInThreadExit() - || ((GetStdHandle(STD_INPUT_HANDLE) != chanInfoPtr->handle) - && (GetStdHandle(STD_OUTPUT_HANDLE) != chanInfoPtr->handle) - && (GetStdHandle(STD_ERROR_HANDLE) != chanInfoPtr->handle))) { - if (CloseHandle(chanInfoPtr->handle) == FALSE) { - Tcl_WinConvertError(GetLastError()); - errorCode = errno; - } + if (closeHandle && chanInfoPtr->handle != INVALID_HANDLE_VALUE) { + if (CloseHandle(chanInfoPtr->handle) == FALSE) { + Tcl_WinConvertError(GetLastError()); + errorCode = errno; } - chanInfoPtr->handle = NULL; + chanInfoPtr->handle = INVALID_HANDLE_VALUE; } /* @@ -1074,6 +1083,10 @@ ConsoleInputProc( ConsoleHandleInfo *handleInfoPtr; RingSizeT numRead; + if (chanInfoPtr->handle == INVALID_HANDLE_VALUE) { + return 0; /* EOF */ + } + *errorCode = 0; AcquireSRWLockShared(&gConsoleLock); @@ -1086,8 +1099,15 @@ ConsoleInputProc( AcquireSRWLockExclusive(&handleInfoPtr->lock); ReleaseSRWLockShared(&gConsoleLock); /* AFTER acquiring handleInfoPtr->lock */ - numRead = RingBufferOut(&handleInfoPtr->buffer, bufPtr, bufSize, 1); - while (numRead == 0) { + while (1) { + numRead = RingBufferOut(&handleInfoPtr->buffer, bufPtr, bufSize, 1); + /* + * Note: even if channel is closed or has an error, as long there is + * buffered data, we will pass it up. + */ + if (numRead != 0) { + break; + } /* * No data available. * - If an error was recorded, generate that and reset it. @@ -1096,47 +1116,43 @@ ConsoleInputProc( * - Otherwise, if non-blocking return EAGAIN or wait for more data. */ if (handleInfoPtr->lastError != 0) { - Tcl_WinConvertError(handleInfoPtr->lastError); - handleInfoPtr->lastError = 0; - *errorCode = Tcl_GetErrno(); - numRead = -1; + if (handleInfoPtr->lastError == ERROR_INVALID_HANDLE) { + numRead = 0; /* Treat as EOF */ + } + else { + Tcl_WinConvertError(handleInfoPtr->lastError); + handleInfoPtr->lastError = 0; + *errorCode = Tcl_GetErrno(); + numRead = -1; + } + break; } - else if (handleInfoPtr->console == NULL) { + if (handleInfoPtr->console == INVALID_HANDLE_VALUE) { /* EOF - break with numRead == 0 */ + chanInfoPtr->handle = INVALID_HANDLE_VALUE; break; } - else { - if (chanInfoPtr->flags & CONSOLE_ASYNC) { - *errorCode = EAGAIN; - numRead = -1; - } - else { - /* - * Release the lock and sleep. Note that because the channel - * holds a reference count on handleInfoPtr, it will not - * be deallocated while the lock is released. - */ - WakeConditionVariable(&handleInfoPtr->consoleThreadCV); - if (SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, - &handleInfoPtr->lock, - INFINITE, - 0)) { - /* - * Lock is reacquired. However, in the meanwhile another - * thread could have consumed data. So loop continues - * with check of numRead value. - */ - numRead = RingBufferOut( - &handleInfoPtr->buffer, bufPtr, bufSize, 1); - } - else { - /* Report the error */ - Tcl_WinConvertError(GetLastError()); - *errorCode = Tcl_GetErrno(); - numRead = -1; - } - } + if (chanInfoPtr->flags & CONSOLE_ASYNC) { + *errorCode = EAGAIN; + numRead = -1; + break; } + /* + * Release the lock and sleep. Note that because the channel + * holds a reference count on handleInfoPtr, it will not + * be deallocated while the lock is released. + */ + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, + &handleInfoPtr->lock, + INFINITE, + 0)) { + Tcl_WinConvertError(GetLastError()); + *errorCode = Tcl_GetErrno(); + numRead = -1; + break; + } + /* Lock is reacquired, loop back to try again */ } ReleaseSRWLockExclusive(&handleInfoPtr->lock); @@ -1173,6 +1189,12 @@ ConsoleOutputProc( *errorCode = 0; + if (chanInfoPtr->handle == INVALID_HANDLE_VALUE) { + /* Some other thread would have *previously* closed the stdio handle */ + *errorCode = EPIPE; + return -1; + } + AcquireSRWLockShared(&gConsoleLock); handleInfoPtr = FindConsoleInfo(chanInfoPtr); if (handleInfoPtr == NULL) { @@ -1184,52 +1206,50 @@ ConsoleOutputProc( AcquireSRWLockExclusive(&handleInfoPtr->lock); ReleaseSRWLockShared(&gConsoleLock); /* AFTER acquiring handleInfoPtr->lock */ - numWritten = RingBufferIn(&handleInfoPtr->buffer, buf, toWrite, 1); - while (numWritten < toWrite) { + /* Keep looping if until all written. Break out for async and errors */ + numWritten = 0; + while (1) { + /* Check for error and close on every loop. */ if (handleInfoPtr->lastError != 0) { Tcl_WinConvertError(handleInfoPtr->lastError); *errorCode = Tcl_GetErrno(); numWritten = -1; break; } - if (handleInfoPtr->console == NULL) { + if (handleInfoPtr->console == INVALID_HANDLE_VALUE) { *errorCode = EPIPE; + chanInfoPtr->handle = INVALID_HANDLE_VALUE; numWritten = -1; break; } - if (chanInfoPtr->flags & CONSOLE_ASYNC) { - /* Async, just accept whatever was written */ + + numWritten += RingBufferIn( + &handleInfoPtr->buffer, numWritten + buf, toWrite - numWritten, 1); + if (numWritten == toWrite || chanInfoPtr->flags & CONSOLE_ASYNC) { + /* All done or async, just accept whatever was written */ break; } - else { - /* - * Release the lock and sleep. Note that because the channel - * holds a reference count on handleInfoPtr, it will not - * be deallocated while the lock is released. - */ - WakeConditionVariable(&handleInfoPtr->consoleThreadCV); - if (SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, - &handleInfoPtr->lock, - INFINITE, - 0)) { - /* Lock is reacquired. Continue loop */ - numWritten += RingBufferIn(&handleInfoPtr->buffer, - numWritten + buf, - toWrite - numWritten, - 1); - } - else { - /* Report the error */ - Tcl_WinConvertError(GetLastError()); - *errorCode = Tcl_GetErrno(); - numWritten = -1; - break; - } + /* + * Release the lock and sleep. Note that because the channel + * holds a reference count on handleInfoPtr, it will not + * be deallocated while the lock is released. + */ + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, + &handleInfoPtr->lock, + INFINITE, + 0)) { + /* Report the error */ + Tcl_WinConvertError(GetLastError()); + *errorCode = Tcl_GetErrno(); + numWritten = -1; + break; } + /* Lock is reacquired. Continue loop */ } - ReleaseSRWLockExclusive(&handleInfoPtr->lock); WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + ReleaseSRWLockExclusive(&handleInfoPtr->lock); return numWritten; } @@ -1317,7 +1337,6 @@ ConsoleEventProc( else { assert(chanInfoPtr->channel == NULL); freeChannel = 1; - ckfree(chanInfoPtr); } ReleaseSRWLockShared(&gConsoleLock); @@ -1411,8 +1430,13 @@ ConsoleGetHandleProc( { ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; - *handlePtr = chanInfoPtr->handle; - return TCL_OK; + if (chanInfoPtr->handle == INVALID_HANDLE_VALUE) { + return TCL_ERROR; + } + else { + *handlePtr = chanInfoPtr->handle; + return TCL_OK; + } } /* @@ -1555,16 +1579,22 @@ ConsoleReaderThread( * store the last error. It is up to channel handlers to decide * whether to close or what to do. */ + DWORD error; ReleaseSRWLockExclusive(&handleInfoPtr->lock); - handleInfoPtr->lastError = - ReadConsoleChars(handleInfoPtr->console, - (WCHAR *)inputChars, - sizeof(inputChars) / sizeof(WCHAR), - &inputLen); - if (handleInfoPtr->lastError == 0) { + error = ReadConsoleChars(handleInfoPtr->console, + (WCHAR *)inputChars, + sizeof(inputChars) / sizeof(WCHAR), + &inputLen); + AcquireSRWLockExclusive(&handleInfoPtr->lock); + if (error == 0) { inputLen *= sizeof(WCHAR); } - AcquireSRWLockExclusive(&handleInfoPtr->lock); + else { + handleInfoPtr->lastError = error; + if (handleInfoPtr->lastError == ERROR_INVALID_HANDLE) { + handleInfoPtr->console = INVALID_HANDLE_VALUE; + } + } } } @@ -1590,13 +1620,15 @@ ConsoleReaderThread( /* No need for relocking - no other thread should have access to it now */ RingBufferClear(&handleInfoPtr->buffer); - if (handleInfoPtr->console + if (handleInfoPtr->console != INVALID_HANDLE_VALUE && handleInfoPtr->lastError != ERROR_INVALID_HANDLE) { SetConsoleMode(handleInfoPtr->console, handleInfoPtr->initMode); /* - * NOTE: we do not call CloseHandle(handleInfoPtr->console) + * NOTE: we do not call CloseHandle(handleInfoPtr->console) here. * As per the GetStdHandle documentation, it need not be closed. - * TODO - what about when application closes and re-opens? - Test + * Other components may be directly using it. Note however that + * an explicit chan close script command does close the handle + * for all threads. */ } @@ -1710,9 +1742,13 @@ ConsoleWriterThread(LPVOID arg) if (handleInfoPtr->lastError == 0) { handleInfoPtr->lastError = status; } + if (status == ERROR_INVALID_HANDLE) { + handleInfoPtr->console = INVALID_HANDLE_VALUE; + } /* Assume this write is done but keep looping in case * it is a transient error. Not sure just closing handle - * and exiting thread is a good idea. + * and exiting thread is a good idea until all references + * from interp threads are gone. */ break; } @@ -1735,8 +1771,12 @@ ConsoleWriterThread(LPVOID arg) /* * Exiting: * - remove the console from global list - * - close the handle if still valid * - release the structure + * NOTE: we do not call CloseHandle(handleInfoPtr->console) here. + * As per the GetStdHandle documentation, it need not be closed. + * Other components may be directly using it. Note however that + * an explicit chan close script command does close the handle + * for all threads. */ ReleaseSRWLockExclusive(&handleInfoPtr->lock); AcquireSRWLockExclusive(&gConsoleLock); /* Modifying - exclusive lock */ @@ -1751,11 +1791,6 @@ ConsoleWriterThread(LPVOID arg) RingBufferClear(&handleInfoPtr->buffer); - /* - * NOTE: we do not call CloseHandle(handleInfoPtr->console) - * As per the GetStdHandle documentation, it need not be closed. - * TODO - what about when application closes and re-opens? - Test - */ ckfree(handleInfoPtr); @@ -1812,7 +1847,7 @@ AllocateConsoleHandleInfo( } handleInfoPtr->consoleThread = CreateThread( NULL, /* default security descriptor */ - 8192, /* Stack size - will get rounded up to allocation granularity */ + 2*CONSOLE_BUFFER_SIZE, /* Stack size - gets rounded up to granularity */ permissions == TCL_READABLE ? ConsoleReaderThread : ConsoleWriterThread, handleInfoPtr, /* Pass to thread */ 0, /* Flags - no special cases */ -- cgit v0.12 From d51b6f7045d7043fa3ef9c8de6823a3b524ba50e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 1 Jul 2022 14:55:42 +0000 Subject: TclOO version -> 1.3.0 --- generic/tclOO.c | 2 +- generic/tclOO.h | 6 +++--- tests/oo.test | 2 +- tests/ooNext2.test | 2 +- tests/ooUtil.test | 2 +- unix/tclooConfig.sh | 2 +- win/tclooConfig.sh | 2 +- 7 files changed, 9 insertions(+), 9 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 5051659..56423e1 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -137,7 +137,7 @@ static const Tcl_MethodType classConstructor = { * file). */ -static const char *initScript = +static const char initScript[] = #ifndef TCL_NO_DEPRECATED "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};" #endif diff --git a/generic/tclOO.h b/generic/tclOO.h index dea1467..6f18491 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -24,8 +24,8 @@ * win/tclooConfig.sh */ -#define TCLOO_VERSION "1.2.0" -#define TCLOO_PATCHLEVEL TCLOO_VERSION +#define TCLOO_VERSION "1.3" +#define TCLOO_PATCHLEVEL TCLOO_VERSION ".0" #include "tcl.h" @@ -40,7 +40,7 @@ extern "C" { extern const char *TclOOInitializeStubs( Tcl_Interp *, const char *version); #define Tcl_OOInitStubs(interp) \ - TclOOInitializeStubs((interp), TCLOO_VERSION) + TclOOInitializeStubs((interp), TCLOO_PATCHLEVEL) #ifndef USE_TCL_STUBS # define TclOOInitializeStubs(interp, version) (TCLOO_PATCHLEVEL) #endif diff --git a/tests/oo.test b/tests/oo.test index 168baee..ff67cc1 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcl::oo 1.0.3 +package require tcl::oo 1.3.0 if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* diff --git a/tests/ooNext2.test b/tests/ooNext2.test index 3d28f3f..746f9a5 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcl::oo 1.0.3 +package require tcl::oo 1.3.0 if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* diff --git a/tests/ooUtil.test b/tests/ooUtil.test index 9a28c46..c8be9c8 100644 --- a/tests/ooUtil.test +++ b/tests/ooUtil.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcl::oo 1.0.3 +package require tcl::oo 1.3.0 if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* diff --git a/unix/tclooConfig.sh b/unix/tclooConfig.sh index 4c2068c..27efbe9 100644 --- a/unix/tclooConfig.sh +++ b/unix/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.2.0 +TCLOO_VERSION=1.3.0 diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh index 4c2068c..27efbe9 100644 --- a/win/tclooConfig.sh +++ b/win/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.2.0 +TCLOO_VERSION=1.3.0 -- cgit v0.12 From 22084be3ce76a5f408138f297d34ac259baf3051 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 3 Jul 2022 07:40:45 +0000 Subject: Eliminate unnecessary thread wakeups. --- win/tclWinConsole.c | 87 +++++++++++++++++++++++++++++++++++------------------ 1 file changed, 58 insertions(+), 29 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 5100bc1..d59e677 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -56,8 +56,11 @@ static int initialized = 0; #ifdef TCL_CONSOLE_DEBUG #ifndef CONSOLE_BUFFER_SIZE -/* Force tiny to stress synchronization. Must be at least sizeof(WCHAR) :-) */ -#define CONSOLE_BUFFER_SIZE sizeof(WCHAR) +/* + * Force tiny to stress synchronization. Must be at least 2*sizeof(WCHAR) :-) + * to work around Tcl channel bug https://core.tcl-lang.org/tcl/tktview/b3977d199b08e3979a8da970553d5209b3042e9c + */ +#define CONSOLE_BUFFER_SIZE (2*sizeof(WCHAR)) #endif #else #define CONSOLE_BUFFER_SIZE 8000 /* In bytes */ @@ -139,8 +142,7 @@ typedef struct ConsoleHandleInfo { * from under the console thread. Access to individual fields does not need * to be controlled because * - the console thread does not write to any fields - * - changes to the nextWatchingChannelPtr field and CONSOLE_EVENT_QUEUE - * bit flags are under the gConsoleLock lock + * - changes to the nextWatchingChannelPtr field * - changes to other fields do not matter because after being read for * queueing events, they are verified again when the event is received * in the interpreter thread (since they could have changed anyways while @@ -797,14 +799,18 @@ ConsoleSetupProc( handleInfoPtr = FindConsoleInfo(chanInfoPtr); if (handleInfoPtr != NULL) { AcquireSRWLockShared(&handleInfoPtr->lock); - if ((chanInfoPtr->watchMask & TCL_READABLE) - && (RingBufferLength(&handleInfoPtr->buffer) > 0 - || handleInfoPtr->lastError != ERROR_SUCCESS)) { - block = 0; /* Input data available */ + /* Remember at most one of READABLE, WRITABLE set */ + if (chanInfoPtr->watchMask & TCL_READABLE) { + if (RingBufferLength(&handleInfoPtr->buffer) > 0 + || handleInfoPtr->lastError != ERROR_SUCCESS) { + block = 0; /* Input data available */ + } } - else if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { - /* TCL_WRITABLE */ - block = 0; /* Output space available */ + else if (chanInfoPtr->watchMask & TCL_WRITABLE) { + if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { + /* TCL_WRITABLE */ + block = 0; /* Output space available */ + } } ReleaseSRWLockShared(&handleInfoPtr->lock); } @@ -876,13 +882,17 @@ ConsoleCheckProc( if (handleInfoPtr != NULL) { AcquireSRWLockShared(&handleInfoPtr->lock); - if ((chanInfoPtr->watchMask & TCL_READABLE) - && (RingBufferLength(&handleInfoPtr->buffer) > 0 - || handleInfoPtr->lastError != ERROR_SUCCESS)) { - needEvent = 1; /* Input data available or error/EOF */ + /* Rememebr channel is read or write, never both */ + if (chanInfoPtr->watchMask & TCL_READABLE) { + if (RingBufferLength(&handleInfoPtr->buffer) > 0 + || handleInfoPtr->lastError != ERROR_SUCCESS) { + needEvent = 1; /* Input data available or error/EOF */ + } } - else if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { - needEvent = 1; /* Output space available */ + else if (chanInfoPtr->watchMask & TCL_WRITABLE) { + if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { + needEvent = 1; /* Output space available */ + } } ReleaseSRWLockShared(&handleInfoPtr->lock); } @@ -1108,7 +1118,9 @@ ConsoleInputProc( */ if (numRead != 0) { /* If console thread was blocked, awaken it */ - WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + if (freeSpace == 0) { + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + } break; } /* @@ -1209,10 +1221,10 @@ ConsoleOutputProc( AcquireSRWLockExclusive(&handleInfoPtr->lock); ReleaseSRWLockShared(&gConsoleLock); /* AFTER acquiring handleInfoPtr->lock */ - /* Keep looping if until all written. Break out for async and errors */ + /* Keep looping until all written. Break out for async and errors */ numWritten = 0; while (1) { - /* Check for error and close on every loop. */ + /* Check for error and closing on every loop. */ if (handleInfoPtr->lastError != 0) { Tcl_WinConvertError(handleInfoPtr->lastError); *errorCode = Tcl_GetErrno(); @@ -1286,6 +1298,7 @@ ConsoleEventProc( ConsoleEvent *consoleEvPtr = (ConsoleEvent *) evPtr; ConsoleChannelInfo *chanInfoPtr; int freeChannel; + int mask = 0; if (!(flags & TCL_FILE_EVENTS)) { return 0; @@ -1298,6 +1311,12 @@ ConsoleEventProc( * happens in this function. */ + /* + * Global lock used for chanInfoPtr. A read (shared) lock suffices + * because all access is within the channel owning thread with the + * exception of watchers which is a read-only access. See comments + * to ConsoleChannelInfo. + */ AcquireSRWLockShared(&gConsoleLock); chanInfoPtr->flags &= ~CONSOLE_EVENT_QUEUED; @@ -1308,7 +1327,6 @@ ConsoleEventProc( if (chanInfoPtr->channel && chanInfoPtr->threadId == Tcl_GetCurrentThread() && (chanInfoPtr->watchMask & (TCL_READABLE|TCL_WRITABLE))) { ConsoleHandleInfo *handleInfoPtr; - int mask = 0; handleInfoPtr = FindConsoleInfo(chanInfoPtr); if (handleInfoPtr == NULL) { /* Console was closed. EOF->read event only (not write) */ @@ -1318,20 +1336,33 @@ ConsoleEventProc( } else { AcquireSRWLockShared(&handleInfoPtr->lock); - if (chanInfoPtr->watchMask & TCL_READABLE + /* Remember at most one of READABLE, WRITABLE set */ + if ((chanInfoPtr->watchMask & TCL_READABLE) && RingBufferLength(&handleInfoPtr->buffer)) { mask = TCL_READABLE; } - else if (RingBufferFreeSpace(&handleInfoPtr->buffer)) { + else if ((chanInfoPtr->watchMask & TCL_WRITABLE) + && RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { /* Generate write event space available */ mask = TCL_WRITABLE; } ReleaseSRWLockShared(&handleInfoPtr->lock); } - if (mask) { - Tcl_NotifyChannel(chanInfoPtr->channel, mask); - } } + + /* + * Tcl_NotifyChannel can recurse through the file event callback so need + * to release locks first. Our reference still holds so no danger of + * chanInfoPtr being deallocated if the callback closes the channel. + */ + ReleaseSRWLockShared(&gConsoleLock); + if (mask) { + Tcl_NotifyChannel(chanInfoPtr->channel, mask); + /* Note: chanInfoPtr ref count may have changed */ + } + + /* No need to lock - see comments earlier */ + /* Remove the reference to the channel from event record */ if (chanInfoPtr->numRefs > 1) { chanInfoPtr->numRefs -= 1; @@ -1341,7 +1372,6 @@ ConsoleEventProc( assert(chanInfoPtr->channel == NULL); freeChannel = 1; } - ReleaseSRWLockShared(&gConsoleLock); if (freeChannel) ckfree(chanInfoPtr); @@ -1665,7 +1695,6 @@ ConsoleWriterThread(LPVOID arg) { ConsoleHandleInfo *handleInfoPtr = (ConsoleHandleInfo *) arg; ConsoleHandleInfo **iterator; - ConsoleChannelInfo *chanInfoPtr = NULL; BOOL success; RingSizeT numBytes; /* @@ -2029,7 +2058,7 @@ TclWinOpenConsoleChannel( chanInfoPtr, permissions); /* - * Files have default translation of AUTO and ^Z eof char, which means + * Consoles have default translation of auto and ^Z eof char, which means * that a ^Z will be accepted as EOF when reading. */ -- cgit v0.12 From 9f63bab8c7830e435e641fbb591a5d9f514ce3af Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 3 Jul 2022 08:00:32 +0000 Subject: Fix benign gcc unused code warnings --- win/tclWinConsole.c | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index d59e677..653d580 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -225,7 +225,6 @@ static DWORD WriteConsoleChars(HANDLE hConsole, static void RingBufferInit(RingBuffer *ringPtr, RingSizeT capacity); static void RingBufferClear(RingBuffer *ringPtr); static char * RingBufferSegment(const RingBuffer *ringPtr, RingSizeT *lenPtr); -static int RingBufferCheck(const RingBuffer *ringPtr); static RingSizeT RingBufferIn(RingBuffer *ringPtr, const char *srcPtr, RingSizeT srcLen, int partialCopyOk); static RingSizeT RingBufferOut(RingBuffer *ringPtr, char *dstPtr, @@ -236,6 +235,9 @@ static ConsoleHandleInfo *FindConsoleInfo(const ConsoleChannelInfo *); static DWORD WINAPI ConsoleReaderThread(LPVOID arg); static DWORD WINAPI ConsoleWriterThread(LPVOID arg); static void NudgeWatchers(HANDLE consoleHandle); +#ifndef NDEBUG +static int RingBufferCheck(const RingBuffer *ringPtr); +#endif /* * Static data. @@ -500,7 +502,7 @@ RingBufferOut(RingBuffer *ringPtr, * *------------------------------------------------------------------------ */ - static char * + static inline char * RingBufferSegment(const RingBuffer *ringPtr, RingSizeT *lengthPtr) { RINGBUFFER_ASSERT(ringPtr); @@ -515,6 +517,7 @@ RingBufferOut(RingBuffer *ringPtr, return *lengthPtr == 0 ? NULL : ringPtr->start + ringPtr->bufPtr; } +#ifndef NDEBUG static int RingBufferCheck(const RingBuffer *ringPtr) { @@ -522,7 +525,8 @@ RingBufferCheck(const RingBuffer *ringPtr) && ringPtr->start < ringPtr->capacity && ringPtr->length <= ringPtr->capacity); } - +#endif + /* *------------------------------------------------------------------------ * @@ -1756,7 +1760,7 @@ ConsoleWriterThread(LPVOID arg) } /* We have data to write */ - if (numBytes > (sizeof(buffer) / sizeof(buffer[0]))) { + if ((size_t)numBytes > (sizeof(buffer) / sizeof(buffer[0]))) { numBytes = sizeof(buffer); } /* No need to check result, we already checked length bytes available */ -- cgit v0.12 From 6f74f207dda447f590c07d19f73d5da1a5796eb6 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 3 Jul 2022 15:48:33 +0000 Subject: Fix bug 44bbccdd8c. fconfigure was broken for 8.7 console channel --- tests/winConsole.test | 105 ++++++++++++++++++++++++++++++++++++++++++++------ win/tclWinConsole.c | 74 ++++++++++++++++++++--------------- 2 files changed, 136 insertions(+), 43 deletions(-) diff --git a/tests/winConsole.test b/tests/winConsole.test index 795e16d..ae0d939 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -34,25 +34,24 @@ proc yesno {question {default "Y"}} { } proc prompt {prompt} { - set answer "" - # Make sure we are seen but catch because ui and console + # Make sure we are seen but catch because twapi ui and console # packages may not be available catch {twapi::set_foreground_window [twapi::get_console_window]} puts -nonewline stdout "$prompt" - return [gets stdin] + flush stdout } +# Input tests -test winConsole-1.0 {Console blocking gets} -constraints {win interactive xx} -body { - set response [prompt "Type a line of text and press Return\n"] - yesno "Did you type \"$response\"" -} -result 1 +test console-gets-1.0 {Console blocking gets} -constraints {win interactive} -body { + set response [prompt "Type \"xyz\" and hit Enter: "] + gets stdin +} -result xyz -test winConsole-1.1 {Console file channel: non-blocking gets} {win interactive} { +test console-gets-1.1 {Console file channel: non-blocking gets} {win interactive} { set oldmode [fconfigure stdin] - puts stdout "Enter abcdef now: " nonewline - flush stdout + set response [prompt "Type \"abc\" and hit Enter: "] fileevent stdin readable { if {[gets stdin line] >= 0} { set result $line @@ -72,9 +71,93 @@ test winConsole-1.1 {Console file channel: non-blocking gets} {win interactive} set result -} "abcdef" +} abc + +# Output tests + +test console-puts-1.0 {Console blocking puts stdout} -constraints {win interactive} -body { + puts stdout "123" + yesno "Did you see the string \"123\"?" +} -result 1 +test console-puts-1.1 {Console blocking puts stderr} -constraints {win interactive} -body { + puts stderr "456" + yesno "Did you see the string \"456\"?" +} -result 1 +# fconfigure tests + +## stdin + +test console-fconfigure-1.0 { + Console get stdin configuration +} -constraints {win interactive} -body { + lsort [dict keys [fconfigure stdin]] +} -result {-blocking -buffering -buffersize -encoding -eofchar -inputmode -translation} + +set testnum 0 +foreach {opt result} { + -blocking 1 + -buffering line + -buffersize 4096 + -encoding utf-16 + -inputmode normal + -translation auto +} { + test console-fconfigure-1.[incr testnum] "Console get stdin option $opt" \ + -constraints {win interactive} -body { + fconfigure stdin $opt + } -result $result +} +test console-fconfigure-1.[incr testnum] { + Console get stdin option -eofchar +} -constraints {win interactive} -body { + fconfigure stdin -eofchar +} -result \x1a + +test console-fconfigure-1.[incr testnum] { + fconfigure -inputmode password +} -constraints {win interactive} -body { + prompt "Type \"password\" and hit Enter. You should NOT see characters echoed" + fconfigure stdin -inputmode password + gets stdin password + set password_echoed [yesno "Were the characters echoed?"] + prompt "Type \"normal\" and hit Enter. You should see characters echoed" + fconfigure stdin -inputmode normal + gets stdin normal + set normal_echoed [yesno "Were the characters echoed?"] + list $password_echoed $password $normal_echoed $normal + +} -result [list 0 password 1 normal] + +## stdout/stderr +foreach chan {stdout stderr} major {2 3} { + test console-fconfigure-$major.0 "Console get $chan configuration" -constraints { + win interactive + } -body { + lsort [dict keys [fconfigure $chan]] + } -result {-blocking -buffering -buffersize -encoding -eofchar -translation -winsize} + set testnum 0 + foreach {opt result} { + -blocking 1 + -buffersize 4096 + -encoding utf-16 + -translation crlf + } { + test console-fconfigure-$major.[incr testnum] "Console get $chan option $opt" \ + -constraints {win interactive} -body { + fconfigure $chan $opt + } -result $result + } + + test console-fconfigure-$major.[incr testnum] "Console get $chan option -winsize" -constraints {win interactive} -body { + fconfigure $chan -winsize + } -result {\d+ \d+} -match regexp + + test console-fconfigure-$major.[incr testnum] "Console get $chan option -buffering" -constraints {win interactive} -body { + fconfigure $chan -buffering + } -result [expr {$chan eq "stdout" ? "line" : "none"}] +} #cleanup diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 653d580..7ca94ce 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -54,15 +54,14 @@ static int initialized = 0; -#ifdef TCL_CONSOLE_DEBUG -#ifndef CONSOLE_BUFFER_SIZE /* - * Force tiny to stress synchronization. Must be at least 2*sizeof(WCHAR) :-) - * to work around Tcl channel bug https://core.tcl-lang.org/tcl/tktview/b3977d199b08e3979a8da970553d5209b3042e9c + * Permit CONSOLE_BUFFER_SIZE to be defined on build command for stress test. + * + * In theory, at least sizeof(WCHAR) but note the Tcl channel bug + * https://core.tcl-lang.org/tcl/tktview/b3977d199b08e3979a8da970553d5209b3042e9c + * will cause failures in test suite if close to max input line in the suite. */ -#define CONSOLE_BUFFER_SIZE (2*sizeof(WCHAR)) -#endif -#else +#ifndef CONSOLE_BUFFER_SIZE #define CONSOLE_BUFFER_SIZE 8000 /* In bytes */ #endif @@ -1161,7 +1160,7 @@ ConsoleInputProc( * holds a reference count on handleInfoPtr, it will not * be deallocated while the lock is released. */ - //WakeConditionVariable(&handleInfoPtr->consoleThreadCV); TODO - Needed? + // WakeConditionVariable(&handleInfoPtr->consoleThreadCV); // TODO - Needed? if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, &handleInfoPtr->lock, INFINITE, @@ -2263,41 +2262,52 @@ ConsoleGetOptionProc( } } } + else { + /* + * Output channel. Get option -winsize + * Option is readonly and returned by [fconfigure chan -winsize] but not + * returned by [fconfigure chan] without explicit option name. + */ + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-winsize"); + } - /* - * Get option -winsize - * Option is readonly and returned by [fconfigure chan -winsize] but not - * returned by [fconfigure chan] without explicit option name. - */ - - if ((len > 1) && (strncmp(optionName, "-winsize", len) == 0)) { - CONSOLE_SCREEN_BUFFER_INFO consoleInfo; + if (len == 0 || (len > 1 && strncmp(optionName, "-winsize", len) == 0)) { + CONSOLE_SCREEN_BUFFER_INFO consoleInfo; - valid = 1; - if (!GetConsoleScreenBufferInfo(chanInfoPtr->handle, &consoleInfo)) { - Tcl_WinConvertError(GetLastError()); - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't read console size: %s", - Tcl_PosixError(interp))); + valid = 1; + if (!GetConsoleScreenBufferInfo(chanInfoPtr->handle, + &consoleInfo)) { + Tcl_WinConvertError(GetLastError()); + if (interp != NULL) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("couldn't read console size: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; } - return TCL_ERROR; + Tcl_DStringStartSublist(dsPtr); + sprintf(buf, + "%d", + consoleInfo.srWindow.Right - consoleInfo.srWindow.Left + 1); + Tcl_DStringAppendElement(dsPtr, buf); + sprintf(buf, + "%d", + consoleInfo.srWindow.Bottom - consoleInfo.srWindow.Top + 1); + Tcl_DStringAppendElement(dsPtr, buf); + Tcl_DStringEndSublist(dsPtr); } - sprintf(buf, "%d", - consoleInfo.srWindow.Right - consoleInfo.srWindow.Left + 1); - Tcl_DStringAppendElement(dsPtr, buf); - sprintf(buf, "%d", - consoleInfo.srWindow.Bottom - consoleInfo.srWindow.Top + 1); - Tcl_DStringAppendElement(dsPtr, buf); } + if (valid) { return TCL_OK; } if (chanInfoPtr->flags & CONSOLE_READ_OPS) { - return Tcl_BadChannelOption(interp, optionName, "inputmode winsize"); + return Tcl_BadChannelOption(interp, optionName, "inputmode"); } else { - return Tcl_BadChannelOption(interp, optionName, ""); + return Tcl_BadChannelOption(interp, optionName, "winsize"); } } -- cgit v0.12 From a303a1324a67c192bcaa76b3e08c81352d2bf534 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 3 Jul 2022 22:46:17 +0000 Subject: Remove dead code --- win/tclWinConsole.c | 31 ------------------------------- 1 file changed, 31 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 7ca94ce..1b8699c 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -223,7 +223,6 @@ static DWORD WriteConsoleChars(HANDLE hConsole, RingSizeT *nCharsWritten); static void RingBufferInit(RingBuffer *ringPtr, RingSizeT capacity); static void RingBufferClear(RingBuffer *ringPtr); -static char * RingBufferSegment(const RingBuffer *ringPtr, RingSizeT *lenPtr); static RingSizeT RingBufferIn(RingBuffer *ringPtr, const char *srcPtr, RingSizeT srcLen, int partialCopyOk); static RingSizeT RingBufferOut(RingBuffer *ringPtr, char *dstPtr, @@ -486,36 +485,6 @@ RingBufferOut(RingBuffer *ringPtr, return dstCapacity; } -/* - *------------------------------------------------------------------------ - * - * RingBufferSegment -- - * - * Returns a pointer to the leading data segment in the ring buffer. - * - * Results: - * Pointer to start of segment. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------ - */ - static inline char * - RingBufferSegment(const RingBuffer *ringPtr, RingSizeT *lengthPtr) -{ - RINGBUFFER_ASSERT(ringPtr); - if (ringPtr->length <= (ringPtr->capacity - ringPtr->start)) { - /* No content wrap around. */ - *lengthPtr = ringPtr->length; - } - else { - /* Content wraps around so lead segment stretches to end of buffer */ - *lengthPtr = ringPtr->capacity - ringPtr->start; - } - return *lengthPtr == 0 ? NULL : ringPtr->start + ringPtr->bufPtr; -} - #ifndef NDEBUG static int RingBufferCheck(const RingBuffer *ringPtr) -- cgit v0.12 From b5282f380b7cf0d96a9d9414296ca83b6ac6cc70 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 4 Jul 2022 15:32:29 +0000 Subject: Rework reader thread to not do read-ahead as console stdin mode might change --- tests/winConsole.test | 6 +- win/tclWinConsole.c | 192 +++++++++++++++++++++++++++++--------------------- 2 files changed, 114 insertions(+), 84 deletions(-) diff --git a/tests/winConsole.test b/tests/winConsole.test index ae0d939..6d537b2 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -118,12 +118,12 @@ test console-fconfigure-1.[incr testnum] { test console-fconfigure-1.[incr testnum] { fconfigure -inputmode password } -constraints {win interactive} -body { - prompt "Type \"password\" and hit Enter. You should NOT see characters echoed" + prompt "Type \"password\" and hit Enter. You should NOT see characters echoed: " fconfigure stdin -inputmode password gets stdin password - set password_echoed [yesno "Were the characters echoed?"] - prompt "Type \"normal\" and hit Enter. You should see characters echoed" fconfigure stdin -inputmode normal + set password_echoed [yesno "\nWere the characters echoed?"] + prompt "Type \"normal\" and hit Enter. You should see characters echoed: " gets stdin normal set normal_echoed [yesno "Were the characters echoed?"] list $password_echoed $password $normal_echoed $normal diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 1b8699c..46a7225 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -45,14 +45,32 @@ * per thread queues which simplifies lock management particularly because * thread-console relation is not one-one and is likely more performant as * well with fewer locks needing to be obtained. + * + * Some additional design notes/reminders for the future: + * + * All input is done through the reader thread, even synchronous reads of + * stdin which in theory could be done directly by the interpreter threads. + * This is because I'm not entirely confident about multithreaded access to + * the ReadConsole API (probably ok since Microsoft does not warn against + * this) and also the API requires reading an even number of bytes (WCHAR) + * while the channel callback has no such restriction (in theory). + * Accounting for that in the callbacks is doable but slightly tricky while + * straightforward in the reader thread because of its double buffering. + * + * The reader thread does not read ahead. That is, it will not post a read + * until some interpreter thread is actually requesting a read. This is + * because an interpreter may (for example) turn off echo for passwords and + * the read ahead would come in the way of that. + * + * If multiple threads are reading from stdin, the input is sprayed in random + * fashion. This is not good application design and hence no plan to address + * this (not clear what should be done even in theory) + * + * Locks are never held when calling the ReadConsole/WriteConsole API's + * since they may block. */ -/* - * The following variable is used to tell whether this module has been - * initialized. - */ - -static int initialized = 0; +static int gInitialized = 0; /* * Permit CONSOLE_BUFFER_SIZE to be defined on build command for stress test. @@ -127,6 +145,8 @@ typedef struct ConsoleHandleInfo { int numRefs; /* See comments above */ int permissions; /* TCL_READABLE for input consoles, TCL_WRITABLE * for output. Only one or the other can be set. */ + int flags; +#define CONSOLE_DATA_AWAITED 0x0001 /* An interpreter is awaiting data */ } ConsoleHandleInfo; /* @@ -171,9 +191,9 @@ typedef struct ConsoleChannelInfo { * TCL_WRITABLE, or TCL_EXCEPTION: indicates * which events should be reported. */ int flags; /* State flags */ -#define CONSOLE_EVENT_QUEUED (1 << 0) /* Notification event already queued */ -#define CONSOLE_ASYNC (1 << 1) /* Channel is non-blocking. */ -#define CONSOLE_READ_OPS (1 << 2) /* Channel supports read-related ops. */ +#define CONSOLE_EVENT_QUEUED 0x0001 /* Notification event already queued */ +#define CONSOLE_ASYNC 0x0002 /* Channel is non-blocking. */ +#define CONSOLE_READ_OPS 0x0004 /* Channel supports read-related ops. */ } ConsoleChannelInfo; /* @@ -622,10 +642,10 @@ ConsoleInit(void) * is a speed enhancement. */ - if (!initialized) { + if (!gInitialized) { AcquireSRWLockExclusive(&gConsoleLock); - if (!initialized) { - initialized = 1; + if (!gInitialized) { + gInitialized = 1; Tcl_CreateExitHandler(ProcExitHandler, NULL); } ReleaseSRWLockExclusive(&gConsoleLock); @@ -686,7 +706,7 @@ ProcExitHandler( TCL_UNUSED(ClientData)) { AcquireSRWLockExclusive(&gConsoleLock); - initialized = 0; + gInitialized = 0; ReleaseSRWLockExclusive(&gConsoleLock); } @@ -1090,15 +1110,13 @@ ConsoleInputProc( */ if (numRead != 0) { /* If console thread was blocked, awaken it */ - if (freeSpace == 0) { - WakeConditionVariable(&handleInfoPtr->consoleThreadCV); - } + // XXX WakeConditionVariable(&handleInfoPtr->consoleThreadCV); break; } /* * No data available. * - If an error was recorded, generate that and reset it. - * - If EOF, indicate as much. It is up to application to close + * - If EOF, indicate as much. It is up to the application to close * the channel. * - Otherwise, if non-blocking return EAGAIN or wait for more data. */ @@ -1119,21 +1137,26 @@ ConsoleInputProc( chanInfoPtr->handle = INVALID_HANDLE_VALUE; break; } + /* Request console reader thread for data */ + handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + + /* For async, tell caller we are blocked */ if (chanInfoPtr->flags & CONSOLE_ASYNC) { *errorCode = EWOULDBLOCK; numRead = -1; break; } + /* * Release the lock and sleep. Note that because the channel * holds a reference count on handleInfoPtr, it will not * be deallocated while the lock is released. */ - // WakeConditionVariable(&handleInfoPtr->consoleThreadCV); // TODO - Needed? if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, - &handleInfoPtr->lock, - INFINITE, - 0)) { + &handleInfoPtr->lock, + INFINITE, + 0)) { Tcl_WinConvertError(GetLastError()); *errorCode = Tcl_GetErrno(); numRead = -1; @@ -1370,9 +1393,9 @@ ConsoleEventProc( static void ConsoleWatchProc( ClientData instanceData, /* Console state. */ - int permissions) /* What events to watch for, OR-ed combination - * of TCL_READABLE, TCL_WRITABLE and - * TCL_EXCEPTION. */ + int newMask) /* What events to watch for, one of + * of TCL_READABLE, TCL_WRITABLE + */ { ConsoleChannelInfo **nextPtrPtr, *ptr; ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; @@ -1383,15 +1406,27 @@ ConsoleWatchProc( * need to update the watchMask and then force the notifier to poll once. */ - chanInfoPtr->watchMask = permissions & chanInfoPtr->permissions; + chanInfoPtr->watchMask = newMask & chanInfoPtr->permissions; if (chanInfoPtr->watchMask) { Tcl_Time blockTime = { 0, 0 }; if (!oldMask) { - /* Add to list of watched channels */ AcquireSRWLockExclusive(&gConsoleLock); + /* Add to list of watched channels */ chanInfoPtr->nextWatchingChannelPtr = gWatchingChannelList; gWatchingChannelList = chanInfoPtr; + + /* + * For read channels, need to tell the console reader thread + * that we are looking for data since it will not do reads until + * it knows someone is awaiting. + */ + ConsoleHandleInfo *handleInfoPtr; + handleInfoPtr = FindConsoleInfo(chanInfoPtr); + if (handleInfoPtr) { + handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + } ReleaseSRWLockExclusive(&gConsoleLock); } Tcl_SetMaxBlockTime(&blockTime); @@ -1475,7 +1510,7 @@ ConsoleReaderThread( /* * Keep looping until one of the following happens. * - * - there are not more channels listening on the console + * - there are no more channels listening on the console * - the console handle has been closed * * On each iteration, @@ -1499,43 +1534,14 @@ ConsoleReaderThread( } /* - * Cases: - * (1) The shared input buffer is full. Have to wait for an interp - * thread to read from it and make room. - * (2) The shared input buffer has room and the thread private buffer - * has data. Copy into the shared input buffer. - * (3) The channel has previously seen an error. Treat as EOF. Note - * this check is after the above so any data already available - * is passed on. - * (4) Neither buffer has data and no errors. Go get some from console. - * - * There is some duplication of code below but easier to think about - * rather than combining cases. + * Shared buffer has no data. If we have some in our private buffer + * copy that. Else check if there has been an error. In both cases + * notify the interp threads. */ - if (RingBufferFreeSpace(&handleInfoPtr->buffer) == 0) { - /* Case (1) No room in buffer.*/ - - /* Awaken any reader channels - TODO - is this needed? */ - // WakeConditionVariable(&handleInfoPtr->interpThreadCV); - - /* Release lock and wait for room */ - success = SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV, - &handleInfoPtr->lock, - INFINITE, - 0); - /* Note: lock has been reacquired */ - - if (!success && GetLastError() != ERROR_TIMEOUT) { - /* TODO - what can be done? Should not happen */ - /* For now keep going */ - } - } else if (inputLen > 0 || handleInfoPtr->lastError != 0) { - /* Cases (2) and (3) - require notifications to interpreters */ + if (inputLen > 0 || handleInfoPtr->lastError != 0) { HANDLE consoleHandle; if (inputLen > 0) { - /* - * Case (2). Private buffer has data. Copy it over. - */ + /* Private buffer has data. Copy it over. */ RingSizeT nStored; assert((inputLen - inputOffset) > 0); @@ -1553,43 +1559,54 @@ ConsoleReaderThread( } else { /* - * Case (3). On error, nothing but inform caller and wait + * On error, nothing but inform caller and wait * We do not want to exit until there are no client interps. */ } /* - * Wake up any threads waiting synchronously. Really we only - * to do this if buffer was previously empty, blocking readers - * but whatever...don't further complicate things. + * Wake up any threads waiting either synchronously or + * asynchronously. Since we are providing data, turn off the + * AWAITED flag. If the data provided is not sufficient the + * clients will request again. Note we have to wake up ALL + * awaiting threads, not just one, so they can all reissue + * requests if needed. (In a properly designed app, at most one + * thread should be reading standard input but...) */ - WakeConditionVariable(&handleInfoPtr->interpThreadCV); - + handleInfoPtr->flags &= ~CONSOLE_DATA_AWAITED; + /* Wake synchronous channels */ + WakeAllConditionVariable(&handleInfoPtr->interpThreadCV); /* - * Wake up all channels registered for file events. Note in + * Wake up async channels registered for file events. Note in * order to follow the locking hierarchy, we need to release - * handleInfoPtr->lock before acquiring gConsoleLock and - * relock it. + * handleInfoPtr->lock before calling NudgeWatchers. */ consoleHandle = handleInfoPtr->console; - /* - * Wake up all channels registered for file events. Note in - * order to follow the locking hierarchy, we cannot hold any locks - * when calling NudgeWatchers. - */ ReleaseSRWLockExclusive(&handleInfoPtr->lock); NudgeWatchers(consoleHandle); - AcquireSRWLockExclusive(&handleInfoPtr->lock); - } - else { + /* - * Case (4). Need to go get more data from console. We only - * store the last error. It is up to channel handlers to decide - * whether to close or what to do. + * Loop back to recheck for exit conditions changes while the + * the lock was not held. */ + continue; + } + + /* + * Both shared buffer and private buffer are empty. Need to go get + * data from console but do not want to read ahead because the + * interp thread might change the read mode, e.g. turning off echo + * for password input. So only do so if at least one interpreter has + * requested data. + */ + if (handleInfoPtr->flags & CONSOLE_DATA_AWAITED) { DWORD error; + /* Do not hold the lock while blocked in console */ ReleaseSRWLockExclusive(&handleInfoPtr->lock); + /* + * Note - the temporary buffer serves two purposes. It + */ error = ReadConsoleChars(handleInfoPtr->console, (WCHAR *)inputChars, sizeof(inputChars) / sizeof(WCHAR), @@ -1599,12 +1616,25 @@ ConsoleReaderThread( inputLen *= sizeof(WCHAR); } else { + /* + * We only store the last error. It is up to channel + * handlers whether to close or not in case of errors. + */ handleInfoPtr->lastError = error; if (handleInfoPtr->lastError == ERROR_INVALID_HANDLE) { handleInfoPtr->console = INVALID_HANDLE_VALUE; } } } + else { + /* Wait until an interp thread asks for data. */ + success = SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV, + &handleInfoPtr->lock, + INFINITE, + 0); + } + + /* Loop again to check for exit or wait for readers to wake us */ } /* -- cgit v0.12 From 4ff49ce2f1d1884d64e2652b069483b65234caa2 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 4 Jul 2022 15:59:37 +0000 Subject: Merge core-8-branch --- win/tclWinConsole.c | 6 ------ 1 file changed, 6 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 46a7225..f1201ce 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -1509,14 +1509,8 @@ ConsoleReaderThread( /* * Keep looping until one of the following happens. - * * - there are no more channels listening on the console * - the console handle has been closed - * - * On each iteration, - * - if the channel buffer is full, wait for some channel reader to read - * - if there is data in our input buffer copy it to the channel buffer - * - get more data from the console */ /* This thread is holding a reference so pointer is safe */ -- cgit v0.12 From dda0e7f5f62db678465c31383298f07ab102a2d1 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 4 Jul 2022 16:54:18 +0000 Subject: Permit direct console writes for synchronous output calls --- win/tclWinConsole.c | 83 ++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 63 insertions(+), 20 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index f1201ce..4f67b64 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -66,6 +66,9 @@ * fashion. This is not good application design and hence no plan to address * this (not clear what should be done even in theory) * + * For output, we do not restrict all output to the console writer threads. + * See ConsoleOutputProc for the conditions. + * * Locks are never held when calling the ReadConsole/WriteConsole API's * since they may block. */ @@ -1233,31 +1236,71 @@ ConsoleOutputProc( break; } - numWritten += RingBufferIn( - &handleInfoPtr->buffer, numWritten + buf, toWrite - numWritten, 1); - if (numWritten == toWrite || chanInfoPtr->flags & CONSOLE_ASYNC) { - /* All done or async, just accept whatever was written */ - break; - } /* - * Release the lock and sleep. Note that because the channel - * holds a reference count on handleInfoPtr, it will not - * be deallocated while the lock is released. + * We can either write directly or through the console thread's + * ring buffer. We have to do the latter when + * (1) the operation is async since WriteConsoleChars is always blocking + * (2) when there is already data in the ring buffer because we don't + * want to reorder output from within a thread + * (3) when there are an odd number of bytes since WriteConsole + * takes whole WCHARs + * (4) when the pointer is not aligned on WCHAR + * The ring buffer deals with cases (3) and (4). It would be harder + * to duplicate that here. */ - WakeConditionVariable(&handleInfoPtr->consoleThreadCV); - if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, - &handleInfoPtr->lock, - INFINITE, - 0)) { - /* Report the error */ - Tcl_WinConvertError(GetLastError()); - *errorCode = Tcl_GetErrno(); - numWritten = -1; - break; + if ((chanInfoPtr->flags & CONSOLE_ASYNC) /* Case (1) */ + || RingBufferLength(&handleInfoPtr->buffer) != 0 /* Case (2) */ + || (toWrite & 1) != 0 /* Case (3) */ + || (PTR2INT(buf) & 1) != 0 /* Case (4) */ + ) { + numWritten += RingBufferIn(&handleInfoPtr->buffer, + numWritten + buf, + toWrite - numWritten, + 1); + if (numWritten == toWrite || chanInfoPtr->flags & CONSOLE_ASYNC) { + /* All done or async, just accept whatever was written */ + break; + } + /* + * Release the lock and sleep. Note that because the channel + * holds a reference count on handleInfoPtr, it will not + * be deallocated while the lock is released. + */ + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, + &handleInfoPtr->lock, + INFINITE, + 0)) { + /* Report the error */ + Tcl_WinConvertError(GetLastError()); + *errorCode = Tcl_GetErrno(); + numWritten = -1; + break; + } + } + else { + /* Direct output */ + DWORD winStatus; + HANDLE consoleHandle = handleInfoPtr->console; + /* Unlock before blocking in WriteConsole */ + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + /* UNLOCKED so return, DON'T break out of loop as it will unlock again! */ + winStatus = WriteConsoleChars(consoleHandle, + (WCHAR *)buf, + toWrite / sizeof(WCHAR), + &numWritten); + if (winStatus == ERROR_SUCCESS) { + return numWritten * sizeof(WCHAR); + } + else { + Tcl_WinConvertError(winStatus); + *errorCode = Tcl_GetErrno(); + return -1; + } } + /* Lock is reacquired. Continue loop */ } - WakeConditionVariable(&handleInfoPtr->consoleThreadCV); ReleaseSRWLockExclusive(&handleInfoPtr->lock); return numWritten; -- cgit v0.12 From 73390782ea84a72d621c6ebbaf2b18ae9308b93b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 5 Jul 2022 10:20:02 +0000 Subject: Simplify TIP #609 implementation, make TCL_QUEUE_ALERT_IF_EMPTY work for all positions and improve documentation --- doc/Notifier.3 | 2 +- generic/tcl.decls | 4 ++-- generic/tclDecls.h | 8 ++++---- generic/tclNotify.c | 38 +++++++++++++++++--------------------- 4 files changed, 24 insertions(+), 28 deletions(-) diff --git a/doc/Notifier.3 b/doc/Notifier.3 index 3b547ff..7cb02f6 100644 --- a/doc/Notifier.3 +++ b/doc/Notifier.3 @@ -90,7 +90,7 @@ necessary. .AP Tcl_Event *evPtr in An event to add to the event queue. The storage for the event must have been allocated by the caller using \fBTcl_Alloc\fR or \fBckalloc\fR. -.AP int flags in +.AP int position in Where to add the new event in the queue: \fBTCL_QUEUE_TAIL\fR, \fBTCL_QUEUE_HEAD\fR, \fBTCL_QUEUE_MARK\fR, and whether to do an alert if the queue is empty: \fBTCL_QUEUE_ALERT_IF_EMPTY\fR. diff --git a/generic/tcl.decls b/generic/tcl.decls index 8b78c7e..99c0e25 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -734,7 +734,7 @@ declare 204 { const char *Tcl_PosixError(Tcl_Interp *interp) } declare 205 { - void Tcl_QueueEvent(Tcl_Event *evPtr, int flags) + void Tcl_QueueEvent(Tcl_Event *evPtr, int position) } declare 206 { int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead) @@ -1144,7 +1144,7 @@ declare 318 { } declare 319 { void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr, - int flags) + int position) } declare 320 { int Tcl_UniCharAtIndex(const char *src, int index) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index a53f25d..b869c97 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -642,7 +642,7 @@ EXTERN int Tcl_PutEnv(const char *assignment); /* 204 */ EXTERN const char * Tcl_PosixError(Tcl_Interp *interp); /* 205 */ -EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, int flags); +EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, int position); /* 206 */ EXTERN int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead); /* 207 */ @@ -980,7 +980,7 @@ EXTERN Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1, EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId); /* 319 */ EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, - Tcl_Event *evPtr, int flags); + Tcl_Event *evPtr, int position); /* 320 */ EXTERN int Tcl_UniCharAtIndex(const char *src, int index); /* 321 */ @@ -2215,7 +2215,7 @@ typedef struct TclStubs { void (*tcl_PrintDouble) (Tcl_Interp *interp, double value, char *dst); /* 202 */ int (*tcl_PutEnv) (const char *assignment); /* 203 */ const char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */ - void (*tcl_QueueEvent) (Tcl_Event *evPtr, int flags); /* 205 */ + void (*tcl_QueueEvent) (Tcl_Event *evPtr, int position); /* 205 */ int (*tcl_Read) (Tcl_Channel chan, char *bufPtr, int toRead); /* 206 */ void (*tcl_ReapDetachedProcs) (void); /* 207 */ int (*tcl_RecordAndEval) (Tcl_Interp *interp, const char *cmd, int flags); /* 208 */ @@ -2329,7 +2329,7 @@ typedef struct TclStubs { int (*tcl_SetSystemEncoding) (Tcl_Interp *interp, const char *name); /* 316 */ Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */ void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */ - void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, int flags); /* 319 */ + void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, int position); /* 319 */ int (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */ int (*tcl_UniCharToLower) (int ch); /* 321 */ int (*tcl_UniCharToTitle) (int ch); /* 322 */ diff --git a/generic/tclNotify.c b/generic/tclNotify.c index 8613e98..e17819e 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -96,7 +96,7 @@ TCL_DECLARE_MUTEX(listLock) */ static int QueueEvent(ThreadSpecificData *tsdPtr, - Tcl_Event *evPtr, int flags); + Tcl_Event *evPtr, int position); /* *---------------------------------------------------------------------- @@ -175,8 +175,7 @@ TclFinalizeNotifier(void) Tcl_Event *evPtr, *hold; if (!tsdPtr->initialized) { - return; /* Notifier not initialized for the current - * thread. */ + return; /* Notifier not initialized for the current thread */ } Tcl_MutexLock(&(tsdPtr->queueMutex)); @@ -310,7 +309,7 @@ Tcl_CreateEventSource( * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - EventSource *sourcePtr = (EventSource *) ckalloc(sizeof(EventSource)); + EventSource *sourcePtr = (EventSource *)ckalloc(sizeof(EventSource)); sourcePtr->setupProc = setupProc; sourcePtr->checkProc = checkProc; @@ -392,12 +391,12 @@ Tcl_QueueEvent( * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - int flags) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, - * TCL_QUEUE_MARK, possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */ + int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, + * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - (void) QueueEvent(tsdPtr, evPtr, flags); + QueueEvent(tsdPtr, evPtr, position); } /* @@ -424,8 +423,8 @@ Tcl_ThreadQueueEvent( * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - int flags) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, - * TCL_QUEUE_MARK, possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */ + int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, + * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */ { ThreadSpecificData *tsdPtr; @@ -444,7 +443,7 @@ Tcl_ThreadQueueEvent( */ if (tsdPtr) { - if (QueueEvent(tsdPtr, evPtr, flags)) { + if (QueueEvent(tsdPtr, evPtr, position)) { Tcl_AlertNotifier(tsdPtr->clientData); } } else { @@ -484,15 +483,14 @@ QueueEvent( * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - int flags) - /* One of TCL_QUEUE_TAIL_EX, - * TCL_QUEUE_HEAD_EX, TCL_QUEUE_MARK_EX, + int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY */ { - int wasEmpty = 0; - Tcl_MutexLock(&(tsdPtr->queueMutex)); - if ((flags & 3) == TCL_QUEUE_TAIL) { + if (tsdPtr->firstEventPtr != NULL) { + position &= ~TCL_QUEUE_ALERT_IF_EMPTY; + } + if ((position & 3) == TCL_QUEUE_TAIL) { /* * Append the event on the end of the queue. */ @@ -500,12 +498,11 @@ QueueEvent( evPtr->nextPtr = NULL; if (tsdPtr->firstEventPtr == NULL) { tsdPtr->firstEventPtr = evPtr; - wasEmpty = (flags & TCL_QUEUE_ALERT_IF_EMPTY) ? 1 : 0; } else { tsdPtr->lastEventPtr->nextPtr = evPtr; } tsdPtr->lastEventPtr = evPtr; - } else if ((flags & 3) == TCL_QUEUE_HEAD) { + } else if ((position & 3) == TCL_QUEUE_HEAD) { /* * Push the event on the head of the queue. */ @@ -513,10 +510,9 @@ QueueEvent( evPtr->nextPtr = tsdPtr->firstEventPtr; if (tsdPtr->firstEventPtr == NULL) { tsdPtr->lastEventPtr = evPtr; - wasEmpty = (flags & TCL_QUEUE_ALERT_IF_EMPTY) ? 1 : 0; } tsdPtr->firstEventPtr = evPtr; - } else if ((flags & 3) == TCL_QUEUE_MARK) { + } else if ((position & 3) == TCL_QUEUE_MARK) { /* * Insert the event after the current marker event and advance the * marker to the new event. @@ -535,7 +531,7 @@ QueueEvent( } } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); - return wasEmpty; + return position & TCL_QUEUE_ALERT_IF_EMPTY; } /* -- cgit v0.12 From 1469d7388d67343a410fc0157dedeaa7deb27ddd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 5 Jul 2022 12:03:18 +0000 Subject: Prevent warning: zero size arrays are an extension [-Wzero-length-array], when using C99 --- generic/tclInt.h | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index e238728..63fcf62 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -877,7 +877,9 @@ typedef struct VarInHash { *---------------------------------------------------------------- */ -#if defined(__GNUC__) && (__GNUC__ > 2) +#if defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) +# define TCLFLEXARRAY +#elif defined(__GNUC__) && (__GNUC__ > 2) # define TCLFLEXARRAY 0 #else # define TCLFLEXARRAY 1 -- cgit v0.12 From eb33dbb186b524be57dd9b4c2ebb9b703cb5080a Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 5 Jul 2022 15:54:00 +0000 Subject: Fix channel close on thread exit if other threads exist. Add winconsole tests. --- tests/winConsole.test | 237 +++++++++++++++++++++++++++++++++++++++++++------- win/tclWinConsole.c | 33 +++++-- 2 files changed, 231 insertions(+), 39 deletions(-) diff --git a/tests/winConsole.test b/tests/winConsole.test index 6d537b2..cb1babc 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -14,7 +14,9 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -::tcltest::ConstraintInitializer twapi { expr {![catch {package require twapi}]} } +catch {package require twapi} ;# Only to bring window to foreground. Not critical + +::tcltest::ConstraintInitializer haveThread { expr {![catch {package require Thread}]} } # Prompt user for a yes/no response proc yesno {question {default "Y"}} { @@ -44,14 +46,16 @@ proc prompt {prompt} { # Input tests test console-gets-1.0 {Console blocking gets} -constraints {win interactive} -body { - set response [prompt "Type \"xyz\" and hit Enter: "] + prompt "Type \"xyz\" and hit Enter: " gets stdin } -result xyz -test console-gets-1.1 {Console file channel: non-blocking gets} {win interactive} { +test console-gets-1.1 {Console file channel: non-blocking gets} -constraints { + win interactive tbd +} -body { set oldmode [fconfigure stdin] - set response [prompt "Type \"abc\" and hit Enter: "] + prompt "Type \"abc\" and hit Enter: " fileevent stdin readable { if {[gets stdin line] >= 0} { set result $line @@ -68,10 +72,55 @@ test console-gets-1.1 {Console file channel: non-blocking gets} {win interactive #cleanup the fileevent fileevent stdin readable {} fconfigure stdin {*}$oldmode - + puts [fconfigure stdin] set result -} abc +} -result abc + +test console-read-1.0 {Console blocking read} -constraints {win interactive} -setup { + set oldmode [fconfigure stdin] + fconfigure stdin -inputmode raw +} -cleanup { + fconfigure stdin {*}$oldmode +} -body { + puts [fconfigure stdin] + prompt "Type the key \"a\". Do NOT hit Enter. You will NOT see characters echoed." + set c [read stdin 1] + puts "" + set c +} -result a + +test console-read-1.1 {Console file channel: non-blocking read} -constraints { + win interactive +} -setup { + set oldmode [fconfigure stdin] +} -cleanup { + fconfigure stdin {*}$oldmode +} -body { + set input "" + fconfigure stdin -blocking 0 -buffering line -inputmode raw + prompt "Type \"abc\". Do NOT hit Enter. You will NOT see characters echoed." + + fileevent stdin readable { + set c [read stdin 1] + if {$c eq ""} { + if {[eof stdin]} { + set result "read eof" + } + } else { + append input $c + if {[string length $input] == 3} { + set result $input + } + } + } + + set result {} + vwait result + fileevent stdin readable {} + puts "" + set result +} -result abc # Output tests @@ -80,16 +129,39 @@ test console-puts-1.0 {Console blocking puts stdout} -constraints {win interacti yesno "Did you see the string \"123\"?" } -result 1 -test console-puts-1.1 {Console blocking puts stderr} -constraints {win interactive} -body { +test console-puts-1.1 {Console non-blocking puts stdout} -constraints { + win interactive +} -setup { + set oldmode [fconfigure stdout] + dict unset oldmode -winsize +} -cleanup { + fconfigure stdout {*}$oldmode +} -body { + fconfigure stdout -blocking 0 -buffering line + set count 0 + fileevent stdout writable { + if {[incr count] < 4} { + puts "$count" + } else { + fileevent stdout writable {} + set done 1 + } + } + vwait done + yesno "Did you see 1, 2, 3 printed on consecutive lines?" +} -result 1 + +test console-puts-2.0 {Console blocking puts stderr} -constraints {win interactive} -body { puts stderr "456" yesno "Did you see the string \"456\"?" } -result 1 -# fconfigure tests -## stdin +# fconfigure get tests + +## fconfigure get stdin -test console-fconfigure-1.0 { +test console-fconfigure-get-1.0 { Console get stdin configuration } -constraints {win interactive} -body { lsort [dict keys [fconfigure stdin]] @@ -104,35 +176,26 @@ foreach {opt result} { -inputmode normal -translation auto } { - test console-fconfigure-1.[incr testnum] "Console get stdin option $opt" \ + test console-fconfigure-get-1.[incr testnum] "Console get stdin option $opt" \ -constraints {win interactive} -body { fconfigure stdin $opt } -result $result } -test console-fconfigure-1.[incr testnum] { +test console-fconfigure-get-1.[incr testnum] { Console get stdin option -eofchar } -constraints {win interactive} -body { fconfigure stdin -eofchar } -result \x1a -test console-fconfigure-1.[incr testnum] { - fconfigure -inputmode password -} -constraints {win interactive} -body { - prompt "Type \"password\" and hit Enter. You should NOT see characters echoed: " - fconfigure stdin -inputmode password - gets stdin password - fconfigure stdin -inputmode normal - set password_echoed [yesno "\nWere the characters echoed?"] - prompt "Type \"normal\" and hit Enter. You should see characters echoed: " - gets stdin normal - set normal_echoed [yesno "Were the characters echoed?"] - list $password_echoed $password $normal_echoed $normal - -} -result [list 0 password 1 normal] +test console-fconfigure-get-1.[incr testnum] { + fconfigure -winsize +} -body { + fconfigure stdin -winsize +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -inputmode} -returnCodes error -## stdout/stderr +## fconfigure get stdout/stderr foreach chan {stdout stderr} major {2 3} { - test console-fconfigure-$major.0 "Console get $chan configuration" -constraints { + test console-fconfigure-get-$major.0 "Console get $chan configuration" -constraints { win interactive } -body { lsort [dict keys [fconfigure $chan]] @@ -144,23 +207,133 @@ foreach chan {stdout stderr} major {2 3} { -encoding utf-16 -translation crlf } { - test console-fconfigure-$major.[incr testnum] "Console get $chan option $opt" \ + test console-fconfigure-get-$major.[incr testnum] "Console get $chan option $opt" \ -constraints {win interactive} -body { fconfigure $chan $opt } -result $result } - test console-fconfigure-$major.[incr testnum] "Console get $chan option -winsize" -constraints {win interactive} -body { + test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -winsize" -constraints {win interactive} -body { fconfigure $chan -winsize } -result {\d+ \d+} -match regexp - test console-fconfigure-$major.[incr testnum] "Console get $chan option -buffering" -constraints {win interactive} -body { + test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -buffering" -constraints {win interactive} -body { fconfigure $chan -buffering } -result [expr {$chan eq "stdout" ? "line" : "none"}] + + test console-fconfigure-get-$major.[incr testnum] { + fconfigure -inputmode + } -body { + fconfigure $chan -inputmode + } -result {bad option "-inputmode": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -winsize} -returnCodes error + } +## fconfigure set stdin + +test console-fconfigure-set-1.0 { + fconfigure -inputmode password +} -constraints {win interactive} -body { + set result {} + + prompt "Type \"pass\" and hit Enter. You should NOT see characters echoed: " + fconfigure stdin -inputmode password + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + fconfigure stdin -inputmode normal + lappend result [yesno "\nWere the characters echoed?"] + + prompt "Type \"norm\" and hit Enter. You should see characters echoed: " + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + lappend result [yesno "Were the characters echoed?"] + + set result +} -result [list pass password 0 norm normal 1] + +test console-fconfigure-set-1.1 { + fconfigure -inputmode raw +} -constraints {win interactive} -body { + set result {} + + prompt "Type the keys \"a\", Ctrl-H, \"b\". Do NOT hit Enter. You should NOT see characters echoed: " + fconfigure stdin -inputmode raw + lappend result [read stdin 3] + lappend result [fconfigure stdin -inputmode] + fconfigure stdin -inputmode normal + lappend result [yesno "\nWere the characters echoed?"] + + prompt "\nType the keys \"c\", Ctrl-H, \"d\" and hit Enter. You should see characters echoed: " + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + lappend result [yesno "\nWere the characters echoed (c replaced by d)?"] + + set result +} -result [list a\x08b raw 0 d normal 1] + +test console-fconfigure-set-1.2 { + fconfigure -inputmode reset +} -constraints {win interactive} -body { + set result {} + + prompt "Type \"pass\" and hit Enter. You should NOT see characters echoed: " + fconfigure stdin -inputmode password + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + fconfigure stdin -inputmode reset + lappend result [yesno "\nWere the characters echoed?"] + + prompt "Type \"reset\" and hit Enter. You should see characters echoed: " + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + lappend result [yesno "Were the characters echoed?"] + + set result +} -result [list pass password 0 reset normal 1] + +test console-fconfigure-set-1.3 { + fconfigure stdin -winsize +} -body { + fconfigure stdin -winsize {10 30} +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -inputmode} -returnCodes error + +## fconfigure set stdout,stderr + +test console-fconfigure-set-2.0 { + fconfigure stdout -winsize +} -body { + fconfigure stdout -winsize {10 30} +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} -returnCodes error + +test console-fconfigure-set-3.0 { + fconfigure stderr -winsize +} -body { + fconfigure stderr -winsize {10 30} +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} -returnCodes error -#cleanup +# Multiple threads + +test console-thread-input-1.0 {Get input in thread} -constraints { + win interactive haveThread +} -setup { + set tid [thread::create] +} -cleanup { + thread::release $tid +} -body { + prompt "Type \"xyz\" and hit Enter: " + thread::send $tid {gets stdin} +} -result xyz + +test console-thread-output-1.0 {Output from thread} -constraints { + win interactive haveThread +} -setup { + set tid [thread::create] +} -cleanup { + thread::release $tid +} -body { + thread::send $tid {puts [thread::id]} + yesno "Did you see $tid printed?" +} -result 1 ::tcltest::cleanupTests return diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 4f67b64..2e60c91 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -1014,11 +1014,20 @@ ConsoleCloseProc( */ AcquireSRWLockShared(&handleInfoPtr->lock); - handleInfoPtr->numRefs -= 1; /* Remove reference from this channel */ - handleInfoPtr->console = INVALID_HANDLE_VALUE; + if (closeHandle) { + handleInfoPtr->console = INVALID_HANDLE_VALUE; + } /* Break the thread out of blocking console i/o */ - CancelSynchronousIo(handleInfoPtr->consoleThread); + handleInfoPtr->numRefs -= 1; /* Remove reference from this channel */ + if (handleInfoPtr->numRefs == 1) { + /* + * Abort the i/o if no other threads are listening on it. + * Note without this check, an input line will be skipped on + * the cancel. + */ + CancelSynchronousIo(handleInfoPtr->consoleThread); + } /* * Wake up the console handling thread. Note we do not explicitly @@ -1113,7 +1122,11 @@ ConsoleInputProc( */ if (numRead != 0) { /* If console thread was blocked, awaken it */ - // XXX WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + if (chanInfoPtr->flags & CONSOLE_ASYNC) { + /* Async channels always want read ahead */ + handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + } break; } /* @@ -1167,6 +1180,11 @@ ConsoleInputProc( } /* Lock is reacquired, loop back to try again */ } + if (chanInfoPtr->flags & CONSOLE_ASYNC) { + /* Async channels always want read ahead */ + handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + } ReleaseSRWLockExclusive(&handleInfoPtr->lock); return numRead; @@ -2186,12 +2204,13 @@ ConsoleSetOptionProc( return TCL_ERROR; } if (Tcl_UtfNcasecmp(value, "NORMAL", vlen) == 0) { - mode |= ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT; + mode |= + ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT | ENABLE_PROCESSED_INPUT; } else if (Tcl_UtfNcasecmp(value, "PASSWORD", vlen) == 0) { - mode |= ENABLE_LINE_INPUT; + mode |= ENABLE_LINE_INPUT|ENABLE_PROCESSED_INPUT; mode &= ~ENABLE_ECHO_INPUT; } else if (Tcl_UtfNcasecmp(value, "RAW", vlen) == 0) { - mode &= ~(ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT); + mode &= ~(ENABLE_ECHO_INPUT | ENABLE_LINE_INPUT | ENABLE_PROCESSED_INPUT); } else if (Tcl_UtfNcasecmp(value, "RESET", vlen) == 0) { /* * Reset to the initial mode, whatever that is. -- cgit v0.12 From 403569ef177348b14d7bfb85c2a488ecaf0a2117 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 7 Jul 2022 10:59:46 +0000 Subject: Unnecessary quotes in win/rules.vc --- win/rules.vc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/rules.vc b/win/rules.vc index db65ce7..fdc68e0 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1418,7 +1418,7 @@ OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1 !endif -!if "$(TCL_MAJOR_VERSION)" == "8" +!if $(TCL_MAJOR_VERSION) == 8 !if "$(_USE_64BIT_TIME_T)" == "1" OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1 !endif -- cgit v0.12 From 063aecb05d90ef87d7178fe8dd5d8948052156e8 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 10 Jul 2022 10:21:06 +0000 Subject: Bypass reader thread for blocking reads. --- tests/winConsole.test | 20 ++++---- win/tclWinConsole.c | 129 +++++++++++++++++++++++++++++++++++++++++--------- 2 files changed, 115 insertions(+), 34 deletions(-) diff --git a/tests/winConsole.test b/tests/winConsole.test index cb1babc..d008d5c 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -45,13 +45,13 @@ proc prompt {prompt} { # Input tests -test console-gets-1.0 {Console blocking gets} -constraints {win interactive} -body { +test console-input-1.0 {Console blocking gets} -constraints {win interactive} -body { prompt "Type \"xyz\" and hit Enter: " gets stdin } -result xyz -test console-gets-1.1 {Console file channel: non-blocking gets} -constraints { - win interactive tbd +test console-input-1.1 {Console file channel: non-blocking gets} -constraints { + win interactive } -body { set oldmode [fconfigure stdin] @@ -72,25 +72,23 @@ test console-gets-1.1 {Console file channel: non-blocking gets} -constraints { #cleanup the fileevent fileevent stdin readable {} fconfigure stdin {*}$oldmode - puts [fconfigure stdin] set result } -result abc -test console-read-1.0 {Console blocking read} -constraints {win interactive} -setup { +test console-input-2.0 {Console blocking read} -constraints {win interactive} -setup { set oldmode [fconfigure stdin] fconfigure stdin -inputmode raw } -cleanup { fconfigure stdin {*}$oldmode } -body { - puts [fconfigure stdin] prompt "Type the key \"a\". Do NOT hit Enter. You will NOT see characters echoed." set c [read stdin 1] puts "" set c } -result a -test console-read-1.1 {Console file channel: non-blocking read} -constraints { +test console-input-2.1 {Console file channel: non-blocking read} -constraints { win interactive } -setup { set oldmode [fconfigure stdin] @@ -118,18 +116,18 @@ test console-read-1.1 {Console file channel: non-blocking read} -constraints { set result {} vwait result fileevent stdin readable {} - puts "" set result } -result abc # Output tests -test console-puts-1.0 {Console blocking puts stdout} -constraints {win interactive} -body { +test console-output-1.0 {Console blocking puts stdout} -constraints {win interactive} -body { + puts [fconfigure stdin] puts stdout "123" yesno "Did you see the string \"123\"?" } -result 1 -test console-puts-1.1 {Console non-blocking puts stdout} -constraints { +test console-output-1.1 {Console non-blocking puts stdout} -constraints { win interactive } -setup { set oldmode [fconfigure stdout] @@ -151,7 +149,7 @@ test console-puts-1.1 {Console non-blocking puts stdout} -constraints { yesno "Did you see 1, 2, 3 printed on consecutive lines?" } -result 1 -test console-puts-2.0 {Console blocking puts stderr} -constraints {win interactive} -body { +test console-output-2.0 {Console blocking puts stderr} -constraints {win interactive} -body { puts stderr "456" yesno "Did you see the string \"456\"?" } -result 1 diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 2e60c91..2cc16d9 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -27,7 +27,7 @@ * corresponding to stdin, stdout, stderr) * * - Consoles are created / inherited at process startup. There is currently - * no way in Tcl to programmatically create a console. Even if there were + * no way in Tcl to programmatically create a console. Even if these were * added the above Windows limitation would still apply. * * - Unlike files, sockets etc. where there is a one-to-one @@ -37,8 +37,7 @@ * * - Even with multiple threads, more than one file event handler is unlikely. * It does not make sense for multiple threads to register handlers for - * stdin because the input would be randomly fragmented amongst the threads - * (not even on a per line basis). + * stdin because the input would be randomly fragmented amongst the threads. * * Various design factors are driven by the above, e.g. use of lists instead * of hash tables (at most 3 console handles) and use of global instead of @@ -48,14 +47,8 @@ * * Some additional design notes/reminders for the future: * - * All input is done through the reader thread, even synchronous reads of - * stdin which in theory could be done directly by the interpreter threads. - * This is because I'm not entirely confident about multithreaded access to - * the ReadConsole API (probably ok since Microsoft does not warn against - * this) and also the API requires reading an even number of bytes (WCHAR) - * while the channel callback has no such restriction (in theory). - * Accounting for that in the callbacks is doable but slightly tricky while - * straightforward in the reader thread because of its double buffering. + * Aligned, synchronous reads are done directly by interpreter thread. + * Unaligned or asynchronous reads are done through the reader thread. * * The reader thread does not read ahead. That is, it will not post a read * until some interpreter thread is actually requesting a read. This is @@ -1153,9 +1146,6 @@ ConsoleInputProc( chanInfoPtr->handle = INVALID_HANDLE_VALUE; break; } - /* Request console reader thread for data */ - handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; - WakeConditionVariable(&handleInfoPtr->consoleThreadCV); /* For async, tell caller we are blocked */ if (chanInfoPtr->flags & CONSOLE_ASYNC) { @@ -1165,10 +1155,51 @@ ConsoleInputProc( } /* + * Blocking read. Just get data from directly from console. There + * is a small complication in that we can only read even number + * of bytes (wide-character API) and the destination buffer should be + * WCHAR aligned. If either condition is not met, we defer to the + * reader thread which handles these case rather than dealing with + * them here (which is a little trickier than it might sound.) + */ + if ((1 & (ptrdiff_t)bufPtr) == 0 /* aligned buffer */ + && bufSize > 1 /* Not single byte read */ + ) { + DWORD lastError; + RingSizeT numChars; + ReleaseSRWLockExclusive(&handleInfoPtr->lock); + lastError = ReadConsoleChars(chanInfoPtr->handle, + (WCHAR *)bufPtr, + bufSize / sizeof(WCHAR), + &numChars); + /* NOTE lock released so DON'T break. Return instead */ + if (lastError != ERROR_SUCCESS) { + Tcl_WinConvertError(lastError); + *errorCode = Tcl_GetErrno(); + return -1; + } + else if (numChars > 0) { + /* Successfully read something. */ + return numChars * sizeof(WCHAR); + } + else { + /* + * Ctrl-C/Ctrl-Brk interrupt. Loop around to retry. + * We have to reacquire the lock. No worried about handleInfoPtr + * having gone away since the channel holds a reference. + */ + AcquireSRWLockExclusive(&handleInfoPtr->lock); + continue; + } + } + /* + * Deferring blocking read to reader thread. * Release the lock and sleep. Note that because the channel * holds a reference count on handleInfoPtr, it will not * be deallocated while the lock is released. */ + handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); if (!SleepConditionVariableSRW(&handleInfoPtr->interpThreadCV, &handleInfoPtr->lock, INFINITE, @@ -1178,10 +1209,11 @@ ConsoleInputProc( numRead = -1; break; } + /* Lock is reacquired, loop back to try again */ } + if (chanInfoPtr->flags & CONSOLE_ASYNC) { - /* Async channels always want read ahead */ handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; WakeConditionVariable(&handleInfoPtr->consoleThreadCV); } @@ -1541,6 +1573,49 @@ ConsoleGetHandleProc( } /* + *------------------------------------------------------------------------ + * + * ConsoleDataAvailable -- + * + * Checks if there is data in the console input queue. + * + * Results: + * Returns 1 if the input queue has data, -1 on error else 0 if empty. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ + static int + ConsoleDataAvailable (HANDLE consoleHandle) +{ + INPUT_RECORD input[5]; + DWORD count; + DWORD i; + + /* + * Need at least one keyboard event. + */ + if (PeekConsoleInputW( + consoleHandle, input, sizeof(input) / sizeof(input[0]), &count) + == FALSE) { + return -1; + } + for (i = 0; i < count; ++i) { + /* + * Event must be a keydown because a trailing LF keyup event is always + * present for line based input. + */ + if (input[i].EventType == KEY_EVENT + && input[i].Event.KeyEvent.bKeyDown) { + return 1; + } + } + return 0; +} + +/* *---------------------------------------------------------------------- * * ConsoleReaderThread -- @@ -1563,7 +1638,6 @@ ConsoleReaderThread( { ConsoleHandleInfo *handleInfoPtr = (ConsoleHandleInfo *) arg; ConsoleHandleInfo **iterator; - BOOL success; char inputChars[200]; /* Temporary buffer */ RingSizeT inputLen = 0; RingSizeT inputOffset = 0; @@ -1655,7 +1729,8 @@ ConsoleReaderThread( * for password input. So only do so if at least one interpreter has * requested data. */ - if (handleInfoPtr->flags & CONSOLE_DATA_AWAITED) { + if ((handleInfoPtr->flags & CONSOLE_DATA_AWAITED) + && ConsoleDataAvailable(handleInfoPtr->console)) { DWORD error; /* Do not hold the lock while blocked in console */ ReleaseSRWLockExclusive(&handleInfoPtr->lock); @@ -1682,11 +1757,20 @@ ConsoleReaderThread( } } else { - /* Wait until an interp thread asks for data. */ - success = SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV, - &handleInfoPtr->lock, - INFINITE, - 0); + /* + * Either no one was asking for data, or no data was available. + * In the former case, wait until someone wakes us asking for + * data. In the latter case, there is no alternative but to + * poll since ReadConsole does not support async operation. + * So sleep for a short while and loop back to retry. + */ + DWORD sleepTime; + sleepTime = + handleInfoPtr->flags & CONSOLE_DATA_AWAITED ? 50 : INFINITE; + SleepConditionVariableSRW(&handleInfoPtr->consoleThreadCV, + &handleInfoPtr->lock, + sleepTime, + 0); } /* Loop again to check for exit or wait for readers to wake us */ @@ -1884,7 +1968,6 @@ ConsoleWriterThread(LPVOID arg) RingBufferClear(&handleInfoPtr->buffer); - ckfree(handleInfoPtr); return 0; -- cgit v0.12 From ea55b6cb74c6189bf0a9ce55a94e14c59875af91 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 10 Jul 2022 14:41:19 +0000 Subject: Blech. Remove unused variable --- win/tclWinConsole.c | 1 - 1 file changed, 1 deletion(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 2cc16d9..114b302 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -1107,7 +1107,6 @@ ConsoleInputProc( ReleaseSRWLockShared(&gConsoleLock); /* AFTER acquiring handleInfoPtr->lock */ while (1) { - int freeSpace = RingBufferFreeSpace(&handleInfoPtr->buffer); numRead = RingBufferOut(&handleInfoPtr->buffer, bufPtr, bufSize, 1); /* * Note: even if channel is closed or has an error, as long there is -- cgit v0.12 From 4a38609129a5103a58655c4f4789012c1144f5c7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 10 Jul 2022 20:40:15 +0000 Subject: Minor simplification: Use RingBufferHasFreeSpace() instead of RingBufferFreeSpace --- win/tclWinConsole.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 114b302..4a9a2df 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -97,7 +97,7 @@ typedef struct RingBuffer { RingSizeT length; /* Number of RingBufferChar*/ } RingBuffer; #define RingBufferLength(ringPtr_) ((ringPtr_)->length) -#define RingBufferFreeSpace(ringPtr_) ((ringPtr_)->capacity - (ringPtr_)->length) +#define RingBufferHasFreeSpace(ringPtr_) ((ringPtr_)->length < (ringPtr_)->capacity) #define RINGBUFFER_ASSERT(ringPtr_) assert(RingBufferCheck(ringPtr_)) /* @@ -795,7 +795,7 @@ ConsoleSetupProc( } } else if (chanInfoPtr->watchMask & TCL_WRITABLE) { - if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { + if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) { /* TCL_WRITABLE */ block = 0; /* Output space available */ } @@ -878,7 +878,7 @@ ConsoleCheckProc( } } else if (chanInfoPtr->watchMask & TCL_WRITABLE) { - if (RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { + if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) { needEvent = 1; /* Output space available */ } } @@ -1429,7 +1429,7 @@ ConsoleEventProc( mask = TCL_READABLE; } else if ((chanInfoPtr->watchMask & TCL_WRITABLE) - && RingBufferFreeSpace(&handleInfoPtr->buffer) > 0) { + && RingBufferHasFreeSpace(&handleInfoPtr->buffer)) { /* Generate write event space available */ mask = TCL_WRITABLE; } -- cgit v0.12 From b88529b2f5c7184710ca00b133bccd5660daf989 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 11 Jul 2022 11:24:10 +0000 Subject: Add "win" constraints to tests/winConsole.test, and change one expected test-results on Windows --- tests/winConsole.test | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/winConsole.test b/tests/winConsole.test index d008d5c..a9d9b09 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -187,7 +187,7 @@ test console-fconfigure-get-1.[incr testnum] { test console-fconfigure-get-1.[incr testnum] { fconfigure -winsize -} -body { +} -constraints win -body { fconfigure stdin -winsize } -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -inputmode} -returnCodes error @@ -221,9 +221,9 @@ foreach chan {stdout stderr} major {2 3} { test console-fconfigure-get-$major.[incr testnum] { fconfigure -inputmode - } -body { + } -constraints win -body { fconfigure $chan -inputmode - } -result {bad option "-inputmode": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -winsize} -returnCodes error + } -result {bad option "-inputmode": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} -returnCodes error } @@ -291,7 +291,7 @@ test console-fconfigure-set-1.2 { test console-fconfigure-set-1.3 { fconfigure stdin -winsize -} -body { +} -constraints win -body { fconfigure stdin -winsize {10 30} } -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -inputmode} -returnCodes error -- cgit v0.12 From 91982ba7527160c9c64c671e494999b3dbf54490 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 12 Jul 2022 03:10:50 +0000 Subject: Fix Windows console fconfigure tests to require interactive constraint. Note this means tests are disabled when run with nmake test --- tests/winConsole.test | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/tests/winConsole.test b/tests/winConsole.test index a9d9b09..0daf54c 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -122,7 +122,6 @@ test console-input-2.1 {Console file channel: non-blocking read} -constraints { # Output tests test console-output-1.0 {Console blocking puts stdout} -constraints {win interactive} -body { - puts [fconfigure stdin] puts stdout "123" yesno "Did you see the string \"123\"?" } -result 1 @@ -187,7 +186,7 @@ test console-fconfigure-get-1.[incr testnum] { test console-fconfigure-get-1.[incr testnum] { fconfigure -winsize -} -constraints win -body { +} -constraints {win interactive} -body { fconfigure stdin -winsize } -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -inputmode} -returnCodes error @@ -211,19 +210,21 @@ foreach chan {stdout stderr} major {2 3} { } -result $result } - test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -winsize" -constraints {win interactive} -body { + test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -winsize" \ + -constraints {win interactive} -body { fconfigure $chan -winsize } -result {\d+ \d+} -match regexp - test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -buffering" -constraints {win interactive} -body { + test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -buffering" \ + -constraints {win interactive} -body { fconfigure $chan -buffering } -result [expr {$chan eq "stdout" ? "line" : "none"}] test console-fconfigure-get-$major.[incr testnum] { fconfigure -inputmode - } -constraints win -body { + } -constraints {win interactive} -body { fconfigure $chan -inputmode - } -result {bad option "-inputmode": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} -returnCodes error + } -result {bad option "-inputmode": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -winsize} -returnCodes error } @@ -291,7 +292,7 @@ test console-fconfigure-set-1.2 { test console-fconfigure-set-1.3 { fconfigure stdin -winsize -} -constraints win -body { +} -constraints {win interactive} -body { fconfigure stdin -winsize {10 30} } -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -inputmode} -returnCodes error @@ -299,13 +300,13 @@ test console-fconfigure-set-1.3 { test console-fconfigure-set-2.0 { fconfigure stdout -winsize -} -body { +} -constraints {win interactive} -body { fconfigure stdout -winsize {10 30} } -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} -returnCodes error test console-fconfigure-set-3.0 { fconfigure stderr -winsize -} -body { +} -constraints {win interactive} -body { fconfigure stderr -winsize {10 30} } -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} -returnCodes error -- cgit v0.12 From 505c18d593b11fa682694a7653b17b325c1aac0e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 12 Jul 2022 08:20:45 +0000 Subject: Code cleanup (use {} in if/else statemenets) --- generic/regexec.c | 15 +++++++++------ generic/tclClock.c | 4 ++-- generic/tclCmdMZ.c | 2 +- generic/tclUtf.c | 3 +-- win/tclWinDde.c | 4 ++-- win/tclWinLoad.c | 5 +++-- 6 files changed, 18 insertions(+), 15 deletions(-) diff --git a/generic/regexec.c b/generic/regexec.c index d0d5680..0ab3c88 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -237,10 +237,11 @@ exec( v->err = 0; assert(v->g->ntree >= 0); n = (size_t) v->g->ntree; - if (n <= LOCALDFAS) + if (n <= LOCALDFAS) { v->subdfas = subdfas; - else + } else { v->subdfas = (struct dfa **) MALLOC(n * sizeof(struct dfa *)); + } if (v->subdfas == NULL) { if (v->pmatch != pmatch && v->pmatch != mat) FREE(v->pmatch); @@ -641,10 +642,11 @@ cdissect( break; case '.': /* concatenation */ assert(t->left != NULL && t->right != NULL); - if (t->left->flags & SHORTER) /* reverse scan */ + if (t->left->flags & SHORTER) {/* reverse scan */ er = crevcondissect(v, t, begin, end); - else + } else { er = ccondissect(v, t, begin, end); + } break; case '|': /* alternation */ assert(t->left != NULL); @@ -652,10 +654,11 @@ cdissect( break; case '*': /* iteration */ assert(t->left != NULL); - if (t->left->flags & SHORTER) /* reverse scan */ + if (t->left->flags & SHORTER) {/* reverse scan */ er = creviterdissect(v, t, begin, end); - else + } else { er = citerdissect(v, t, begin, end); + } break; case '(': /* capturing */ assert(t->left != NULL && t->right == NULL); diff --git a/generic/tclClock.c b/generic/tclClock.c index ca1df44..13a5c65 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -1520,9 +1520,9 @@ GetJulianDayFromEraYearMonthDay( * Have to make sure quotient is truncated towards 0 when negative. * See above bug for details. The casts are necessary. */ - if (ym1 >= 0) + if (ym1 >= 0) { ym1o4 = ym1 / 4; - else { + } else { ym1o4 = - (int) (((unsigned int) -ym1) / 4); } #endif diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index c94abbd..3ff9947 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2845,7 +2845,7 @@ TclStringCmp( if (checkEq && (s1len != s2len)) { match = 1; /* This will be reversed below. */ - } else { + } else { /* * The comparison function should compare up to the minimum byte * length only. diff --git a/generic/tclUtf.c b/generic/tclUtf.c index bcae055..8931b39 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -448,8 +448,7 @@ Tcl_UtfToUniChar( * A three-byte-character lead-byte not followed by two trail-bytes * represents itself. */ - } - else if (byte < 0xF5) { + } else if (byte < 0xF5) { if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) { /* * Four-byte-character lead byte followed by at least two trail bytes. diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 2570954..1c10c65 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -1789,9 +1789,9 @@ DdeObjCmd( } if (result == TCL_OK) { - if (objc == 1) + if (objc == 1) { objPtr = objv[0]; - else { + } else { objPtr = Tcl_ConcatObj(objc, objv); } if (riPtr->handlerPtr != NULL) { diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index 1d64d18..9d2d87e 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -112,10 +112,11 @@ TclpDlopen( * first error for reporting purposes. */ if (firstError == ERROR_MOD_NOT_FOUND || - firstError == ERROR_DLL_NOT_FOUND) + firstError == ERROR_DLL_NOT_FOUND) { lastError = GetLastError(); - else + } else { lastError = firstError; + } errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ", Tcl_GetString(pathPtr)); -- cgit v0.12 From f55203403c6ec05a55134dcfea129095e91c098e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 12 Jul 2022 12:23:54 +0000 Subject: Fix [b79df322a9] follow-up: Tcl_NewUnicodeObj truncates strings --- generic/tclStringObj.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 86b3937..10a8627 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -984,7 +984,11 @@ TclGetUnicodeFromObj( { String *stringPtr; +#if TCL_UTF_MAX > 3 + SetUTF16StringFromAny(NULL, objPtr); +#else SetStringFromAny(NULL, objPtr); +#endif stringPtr = GET_STRING(objPtr); if (lengthPtr != NULL) { -- cgit v0.12 From 1e6f410bd20b8576dbd0be31a153d56d48a1dae4 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 12 Jul 2022 12:31:57 +0000 Subject: Fix [b79df322a9]. Tcl_GetUnicode/Tcl_NewUnicodeObj crash. Add tests --- generic/tclStringObj.c | 31 ++++++++++++++++++++++--------- generic/tclTest.c | 41 +++++++++++++++++++++++++++++++++++++++++ tests/string.test | 12 ++++++++++++ 3 files changed, 75 insertions(+), 9 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 86b3937..852c4ff 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -68,6 +68,7 @@ static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); static int UnicodeLength(const Tcl_UniChar *unicode); +static int UTF16Length(const unsigned short *unicode); static void UpdateStringOfString(Tcl_Obj *objPtr); #if (TCL_UTF_MAX) > 3 && !defined(TCL_NO_DEPRECATED) static void DupUTF16StringInternalRep(Tcl_Obj *objPtr, @@ -562,6 +563,10 @@ Tcl_NewUnicodeObj( TclNewObj(objPtr); TclInvalidateStringRep(objPtr); + if (numChars < 0) { + numChars = UTF16Length(unicode); + } + String *stringPtr = (String *)ckalloc((offsetof(String, unicode) + sizeof(unsigned short)) + numChars * sizeof(unsigned short)); memcpy(stringPtr->unicode, unicode, numChars * sizeof(unsigned short)); @@ -984,7 +989,7 @@ TclGetUnicodeFromObj( { String *stringPtr; - SetStringFromAny(NULL, objPtr); + SetUTF16StringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); if (lengthPtr != NULL) { @@ -1451,14 +1456,7 @@ Tcl_SetUnicodeObj( String *stringPtr; if (numChars < 0) { - numChars = 0; - - if (unicode) { - while (numChars >= 0 && unicode[numChars] != 0) { - numChars++; - } - } - stringCheckLimits(numChars); + numChars = UTF16Length(unicode); } /* @@ -1482,6 +1480,21 @@ Tcl_SetUnicodeObj( #endif static int +UTF16Length( + const unsigned short *ucs2Ptr) +{ + int numChars = 0; + + if (ucs2Ptr) { + while (numChars >= 0 && ucs2Ptr[numChars] != 0) { + numChars++; + } + } + stringCheckLimits(numChars); + return numChars; +} + +static int UnicodeLength( const Tcl_UniChar *unicode) { diff --git a/generic/tclTest.c b/generic/tclTest.c index b2632f0..bf5741c 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -222,6 +222,7 @@ static Tcl_ObjCmdProc TestbytestringObjCmd; static Tcl_ObjCmdProc TestsetbytearraylengthObjCmd; static Tcl_ObjCmdProc TestpurebytesobjObjCmd; static Tcl_ObjCmdProc TeststringbytesObjCmd; +static Tcl_ObjCmdProc Testutf16stringObjCmd; static Tcl_CmdProc TestcmdinfoCmd; static Tcl_CmdProc TestcmdtokenCmd; static Tcl_CmdProc TestcmdtraceCmd; @@ -560,6 +561,7 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testutf16string", Testutf16stringObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, @@ -5176,6 +5178,45 @@ TestbytestringObjCmd( /* *---------------------------------------------------------------------- * + * Testutf16stringObjCmd -- + * + * This specifically tests the Tcl_GetUnicode and Tcl_NewUnicodeObj + * C functions which broke in Tcl 8.7 and were undetected by the + * existing test suite. Bug [b79df322a9] + * + * Results: + * Returns the TCL_OK result code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +Testutf16stringObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + int n = 0; + const Tcl_UniChar *p; + (void)dummy; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); + return TCL_ERROR; + } + + p = Tcl_GetUnicode(objv[1]); + Tcl_SetObjResult(interp, Tcl_NewUnicodeObj(p, -1)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestsetCmd -- * * Implements the "testset{err,noerr}" cmds that are used when testing diff --git a/tests/string.test b/tests/string.test index d497b42..d128a0b 100644 --- a/tests/string.test +++ b/tests/string.test @@ -34,6 +34,7 @@ testConstraint testindexobj [expr {[info commands testindexobj] ne {}}] testConstraint testevalex [expr {[info commands testevalex] ne {}}] testConstraint utf16 [expr {[string length \U010000] == 2}] testConstraint testbytestring [llength [info commands testbytestring]] +testConstraint testutf16string [llength [info commands testutf16string]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] @@ -2635,6 +2636,17 @@ test string-32.17.$noComp {string is dict, valid dict packed in invalid dict} { } 0 }; # foreach noComp {0 1} + +test string-bug-b79df322a9 {Tcl_GetUnicode/Tcl_NewUnicodeObj api} -constraints { + testutf16string +} -body { + # This simple test suffices because the bug has nothing to do with + # the actual encoding conversion. The test was added because these + # functions are no longer called within the Tcl core and thus + # not tested by either `string`, not `encoding` tests. + testutf16string "abcde" +} -result abcde + # cleanup rename MemStress {} -- cgit v0.12 From a3eea6dc3f9b7ffcbcff6b1ee933f9ef1189df3f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 13 Jul 2022 07:33:57 +0000 Subject: Fix build with -DTCL_NO_DEPRECATED --- generic/tclStringObj.c | 6 +++++- generic/tclStubInit.c | 1 + generic/tclTest.c | 6 ++---- tests/string.test | 2 +- 4 files changed, 9 insertions(+), 6 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 130379f..b9d603d 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -68,7 +68,9 @@ static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); static int UnicodeLength(const Tcl_UniChar *unicode); +#if !defined(TCL_NO_DEPRECATED) static int UTF16Length(const unsigned short *unicode); +#endif static void UpdateStringOfString(Tcl_Obj *objPtr); #if (TCL_UTF_MAX) > 3 && !defined(TCL_NO_DEPRECATED) static void DupUTF16StringInternalRep(Tcl_Obj *objPtr, @@ -979,6 +981,7 @@ Tcl_GetUnicodeFromObj( } #endif +#if !defined(TCL_NO_DEPRECATED) unsigned short * TclGetUnicodeFromObj( Tcl_Obj *objPtr, /* The object to find the unicode string @@ -1001,6 +1004,7 @@ TclGetUnicodeFromObj( } return stringPtr->unicode; } +#endif /* *---------------------------------------------------------------------- @@ -1481,7 +1485,6 @@ Tcl_SetUnicodeObj( TclInvalidateStringRep(objPtr); stringPtr->allocated = numChars; } -#endif static int UTF16Length( @@ -1497,6 +1500,7 @@ UTF16Length( stringCheckLimits(numChars); return numChars; } +#endif static int UnicodeLength( diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index eae72ba..2b7952d 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -96,6 +96,7 @@ static void uniCodePanic(void) { } # define Tcl_GetUnicode (unsigned short *(*)(Tcl_Obj *))(void *)uniCodePanic # define Tcl_GetUnicodeFromObj (unsigned short *(*)(Tcl_Obj *, int *))(void *)uniCodePanic +# define TclGetUnicodeFromObj (unsigned short *(*)(Tcl_Obj *, size_t *))(void *)uniCodePanic # define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const unsigned short *, int))(void *)uniCodePanic # define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const unsigned short *, int))(void *)uniCodePanic # define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const unsigned short *, int))(void *)uniCodePanic diff --git a/generic/tclTest.c b/generic/tclTest.c index bf5741c..e3c6663 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -5195,14 +5195,12 @@ TestbytestringObjCmd( static int Testutf16stringObjCmd( - ClientData dummy, /* Not used. */ + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - int n = 0; - const Tcl_UniChar *p; - (void)dummy; + const unsigned short *p; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); diff --git a/tests/string.test b/tests/string.test index d128a0b..ba5be14 100644 --- a/tests/string.test +++ b/tests/string.test @@ -2638,7 +2638,7 @@ test string-32.17.$noComp {string is dict, valid dict packed in invalid dict} { }; # foreach noComp {0 1} test string-bug-b79df322a9 {Tcl_GetUnicode/Tcl_NewUnicodeObj api} -constraints { - testutf16string + testutf16string deprecated } -body { # This simple test suffices because the bug has nothing to do with # the actual encoding conversion. The test was added because these -- cgit v0.12 From 037f0d4f7e7b70aaa44f11a934ed52c0fabca0b3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 13 Jul 2022 12:37:35 +0000 Subject: Make List->elements a TCLFLEXARRAY. Improve documentation (backported from 9.0) --- generic/tclCmdIL.c | 6 +- generic/tclInt.h | 8 +- generic/tclInterp.c | 2 +- generic/tclListObj.c | 647 +++++++++++++++++++++++++-------------------------- 4 files changed, 327 insertions(+), 336 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index f32fd98..1197b92 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2901,7 +2901,7 @@ Tcl_LrepeatObjCmd( List *listRepPtr = ListRepPtr(listPtr); listRepPtr->elemCount = elementCount*objc; - dataArray = &listRepPtr->elements; + dataArray = listRepPtr->elements; } /* @@ -3088,7 +3088,7 @@ Tcl_LreverseObjCmd( resultObj = Tcl_NewListObj(elemc, NULL); listRepPtr = ListRepPtr(resultObj); listRepPtr->elemCount = elemc; - dataArray = &listRepPtr->elements; + dataArray = listRepPtr->elements; for (i=0,j=elemc-1 ; ielements; + newArray = listRepPtr->elements; if (group) { for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) { idx = elementPtr->payload.index; diff --git a/generic/tclInt.h b/generic/tclInt.h index 20c4c45..ac6fb54 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2440,14 +2440,14 @@ typedef struct List { * derived from the list representation. May * be ignored if there is no string rep at * all.*/ - Tcl_Obj *elements; /* First list element; the struct is grown to + Tcl_Obj *elements[TCLFLEXARRAY]; /* First list element; the struct is grown to * accommodate all elements. */ } List; #define LIST_MAX \ - (1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *))) + ((int)(((size_t)UINT_MAX - offsetof(List, elements))/sizeof(Tcl_Obj *))) #define LIST_SIZE(numElems) \ - (unsigned)(sizeof(List) + (((numElems) - 1) * sizeof(Tcl_Obj *))) + (TCL_HASH_TYPE)(offsetof(List, elements) + ((numElems) * sizeof(Tcl_Obj *))) /* * Macro used to get the elements of a list object. @@ -2457,7 +2457,7 @@ typedef struct List { ((List *) (listPtr)->internalRep.twoPtrValue.ptr1) #define ListObjGetElements(listPtr, objc, objv) \ - ((objv) = &(ListRepPtr(listPtr)->elements), \ + ((objv) = ListRepPtr(listPtr)->elements, \ (objc) = ListRepPtr(listPtr)->elemCount) #define ListObjLength(listPtr, len) \ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index b87bf7c..4ce2f31 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -1837,7 +1837,7 @@ AliasNRCmd( listPtr = Tcl_NewListObj(cmdc, NULL); listRep = ListRepPtr(listPtr); listRep->elemCount = cmdc; - cmdv = &listRep->elements; + cmdv = listRep->elements; prefv = &aliasPtr->objPtr; memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *)); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index a7f723d..c24809e 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -77,20 +77,22 @@ const Tcl_ObjType tclListType = { * * NewListInternalRep -- * - * Creates a list internal rep with space for objc elements. objc - * must be > 0. If objv!=NULL, initializes with the first objc values - * in that array. If objv==NULL, initalize list internal rep to have - * 0 elements, with space to add objc more. Flag value "p" indicates + * Creates a 'List' structure with space for 'objc' elements. 'objc' must + * be > 0. If 'objv' is not NULL, The list is initialized with first + * 'objc' values in that array. Otherwise the list is initialized to have + * 0 elements, with space to add 'objc' more. Flag value 'p' indicates * how to behave on failure. * - * Results: - * A new List struct with refCount 0 is returned. If some failure - * prevents this then if p=0, NULL is returned and otherwise the - * routine panics. + * Value * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * A new 'List' structure with refCount 0. If some failure + * prevents this NULL is returned if 'p' is 0 , and 'Tcl_Panic' + * is called if it is not. + * + * Effect + * + * The refCount of each value in 'objv' is incremented as it is added + * to the list. * *---------------------------------------------------------------------- */ @@ -140,7 +142,7 @@ NewListInternalRep( int i; listRepPtr->elemCount = objc; - elemPtrs = &listRepPtr->elements; + elemPtrs = listRepPtr->elements; for (i = 0; i < objc; i++) { elemPtrs[i] = objv[i]; Tcl_IncrRefCount(elemPtrs[i]); @@ -154,21 +156,9 @@ NewListInternalRep( /* *---------------------------------------------------------------------- * - * AttemptNewList -- + * AttemptNewList -- * - * Creates a list internal rep with space for objc elements. objc - * must be > 0. If objv!=NULL, initializes with the first objc values - * in that array. If objv==NULL, initalize list internal rep to have - * 0 elements, with space to add objc more. - * - * Results: - * A new List struct with refCount 0 is returned. If some failure - * prevents this then NULL is returned, and an error message is left - * in the interp result, unless interp is NULL. - * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * Like NewListInternalRep, but additionally sets an error message on failure. * *---------------------------------------------------------------------- */ @@ -201,23 +191,20 @@ AttemptNewList( * * Tcl_NewListObj -- * - * This function is normally called when not debugging: i.e., when - * TCL_MEM_DEBUG is not defined. It creates a new list object from an - * (objc,objv) array: that is, each of the objc elements of the array - * referenced by objv is inserted as an element into a new Tcl object. + * Creates a new list object and adds values to it. When TCL_MEM_DEBUG is + * defined, 'Tcl_DbNewListObj' is called instead. * - * When TCL_MEM_DEBUG is defined, this function just returns the result - * of calling the debugging version Tcl_DbNewListObj. + * Value * - * Results: - * A new list object is returned that is initialized from the object - * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned. The new object's string representation is left - * NULL. The resulting new list object has ref count 0. + * A new list 'Tcl_Obj' to which is appended values from 'objv', or if + * 'objc' is less than or equal to zero, a list 'Tcl_Obj' having no + * elements. The string representation of the new 'Tcl_Obj' is set to + * NULL. The refCount of the list is 0. * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * Effect + * + * The refCount of each elements in 'objv' is incremented as it is added + * to the list. * *---------------------------------------------------------------------- */ @@ -268,28 +255,14 @@ Tcl_NewListObj( /* *---------------------------------------------------------------------- * - * Tcl_DbNewListObj -- - * - * This function is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It creates new list objects. It is the same - * as the Tcl_NewListObj function above except that it calls - * Tcl_DbCkalloc directly with the file name and line number from its - * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when - * reporting objects that haven't been freed. + * Tcl_DbNewListObj -- * - * When TCL_MEM_DEBUG is not defined, this function just returns the - * result of calling Tcl_NewListObj. + * Like 'Tcl_NewListObj', but it calls Tcl_DbCkalloc directly with the + * file name and line number from its caller. This simplifies debugging + * since the [memory active] command will report the correct file + * name and line number when reporting objects that haven't been freed. * - * Results: - * A new list object is returned that is initialized from the object - * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned. The new object's string representation is left - * NULL. The new list object has ref count 0. - * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * When TCL_MEM_DEBUG is not defined, 'Tcl_NewListObj' is called instead. * *---------------------------------------------------------------------- */ @@ -348,19 +321,8 @@ Tcl_DbNewListObj( * * Tcl_SetListObj -- * - * Modify an object to be a list containing each of the objc elements of - * the object array referenced by objv. - * - * Results: - * None. - * - * Side effects: - * The object is made a list object and is initialized from the object - * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned. The new object's string representation is left - * NULL. The ref counts of the elements in objv are incremented since the - * list now refers to them. The object's old string and internal - * representations are freed and its type is set NULL. + * Like 'Tcl_NewListObj', but operates on an existing 'Tcl_Obj'instead of + * creating a new one. * *---------------------------------------------------------------------- */ @@ -403,18 +365,20 @@ Tcl_SetListObj( * * TclListObjCopy -- * - * Makes a "pure list" copy of a list value. This provides for the C - * level a counterpart of the [lrange $list 0 end] command, while using - * internals details to be as efficient as possible. + * Creates a new 'Tcl_Obj' which is a pure copy of a list value. This + * provides for the C level a counterpart of the [lrange $list 0 end] + * command, while using internals details to be as efficient as possible. * - * Results: - * Normally returns a pointer to a new Tcl_Obj, that contains the same - * list value as *listPtr does. The returned Tcl_Obj has a refCount of - * zero. If *listPtr does not hold a list, NULL is returned, and if - * interp is non-NULL, an error message is recorded there. + * Value * - * Side effects: - * None. + * The address of the new 'Tcl_Obj' which shares its internal + * representation with 'listPtr', and whose refCount is 0. If 'listPtr' + * is not actually a list, the value is NULL, and an error message is left + * in 'interp' if it is not NULL. + * + * Effect + * + * 'listPtr' is converted to a list if it isn't one already. * *---------------------------------------------------------------------- */ @@ -529,27 +493,30 @@ TclListObjRange( * * Tcl_ListObjGetElements -- * - * This function returns an (objc,objv) array of the elements in a list - * object. + * Retreive the elements in a list 'Tcl_Obj'. * - * Results: - * The return value is normally TCL_OK; in this case *objcPtr is set to - * the count of list elements and *objvPtr is set to a pointer to an - * array of (*objcPtr) pointers to each list element. If listPtr does not - * refer to a list object and the object can not be converted to one, - * TCL_ERROR is returned and an error message will be left in the - * interpreter's result if interp is not NULL. - * - * The objects referenced by the returned array should be treated as - * readonly and their ref counts are _not_ incremented; the caller must - * do that if it holds on to a reference. Furthermore, the pointer and - * length returned by this function may change as soon as any function is - * called on the list object; be careful about retaining the pointer in a - * local data structure. + * Value * - * Side effects: - * The possible conversion of the object referenced by listPtr - * to a list object. + * TCL_OK + * + * A count of list elements is stored, 'objcPtr', And a pointer to the + * array of elements in the list is stored in 'objvPtr'. + * + * The elements accessible via 'objvPtr' should be treated as readonly + * and the refCount for each object is _not_ incremented; the caller + * must do that if it holds on to a reference. Furthermore, the + * pointer and length returned by this function may change as soon as + * any function is called on the list object. Be careful about + * retaining the pointer in a local data structure. + * + * TCL_ERROR + * + * 'listPtr' is not a valid list. An error message is left in the + * interpreter's result if 'interp' is not NULL. + * + * Effect + * + * 'listPtr' is converted to a list object if it isn't one already. * *---------------------------------------------------------------------- */ @@ -570,7 +537,8 @@ Tcl_ListObjGetElements( ListGetInternalRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + int length; (void) Tcl_GetStringFromObj(listPtr, &length); if (length == 0) { @@ -585,7 +553,7 @@ Tcl_ListObjGetElements( ListGetInternalRep(listPtr, listRepPtr); } *objcPtr = listRepPtr->elemCount; - *objvPtr = &listRepPtr->elements; + *objvPtr = listRepPtr->elements; return TCL_OK; } @@ -594,20 +562,27 @@ Tcl_ListObjGetElements( * * Tcl_ListObjAppendList -- * - * This function appends the elements in the list value referenced by - * elemListPtr to the list value referenced by listPtr. + * Appends the elements of elemListPtr to those of listPtr. * - * Results: - * The return value is normally TCL_OK. If listPtr or elemListPtr do not - * refer to list values, TCL_ERROR is returned and an error message is - * left in the interpreter's result if interp is not NULL. + * Value * - * Side effects: - * The reference counts of the elements in elemListPtr are incremented - * since the list now refers to them. listPtr and elemListPtr are - * converted, if necessary, to list objects. Also, appending the new - * elements may cause listObj's array of element pointers to grow. - * listPtr's old string representation, if any, is invalidated. + * TCL_OK + * + * Success. + * + * TCL_ERROR + * + * 'listPtr' or 'elemListPtr' are not valid lists. An error + * message is left in the interpreter's result if 'interp' is not NULL. + * + * Effect + * + * The reference count of each element of 'elemListPtr' as it is added to + * 'listPtr'. 'listPtr' and 'elemListPtr' are converted to 'tclListType' + * if they are not already. Appending the new elements may cause the + * array of element pointers in 'listObj' to grow. If any objects are + * appended to 'listPtr'. Any preexisting string representation of + * 'listPtr' is invalidated. * *---------------------------------------------------------------------- */ @@ -646,24 +621,27 @@ Tcl_ListObjAppendList( * * Tcl_ListObjAppendElement -- * - * This function is a special purpose version of Tcl_ListObjAppendList: - * it appends a single object referenced by objPtr to the list object - * referenced by listPtr. If listPtr is not already a list object, an - * attempt will be made to convert it to one. + * Like 'Tcl_ListObjAppendList', but Appends a single value to a list. * - * Results: - * The return value is normally TCL_OK; in this case objPtr is added to - * the end of listPtr's list. If listPtr does not refer to a list object - * and the object can not be converted to one, TCL_ERROR is returned and - * an error message will be left in the interpreter's result if interp is - * not NULL. + * Value * - * Side effects: - * The ref count of objPtr is incremented since the list now refers to - * it. listPtr will be converted, if necessary, to a list object. Also, - * appending the new element may cause listObj's array of element - * pointers to grow. listPtr's old string representation, if any, is - * invalidated. + * TCL_OK + * + * 'objPtr' is appended to the elements of 'listPtr'. + * + * TCL_ERROR + * + * listPtr does not refer to a list object and the object can not be + * converted to one. An error message will be left in the + * interpreter's result if interp is not NULL. + * + * Effect + * + * If 'listPtr' is not already of type 'tclListType', it is converted. + * The 'refCount' of 'objPtr' is incremented as it is added to 'listPtr'. + * Appending the new element may cause the the array of element pointers + * in 'listObj' to grow. Any preexisting string representation of + * 'listPtr' is invalidated. * *---------------------------------------------------------------------- */ @@ -675,7 +653,8 @@ Tcl_ListObjAppendElement( Tcl_Obj *objPtr) /* Object to append to listPtr's list. */ { List *listRepPtr, *newPtr = NULL; - int numElems, numRequired, needGrow, isShared, attempt; + int numElems, numRequired; + int needGrow, isShared, attempt; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement"); @@ -683,7 +662,8 @@ Tcl_ListObjAppendElement( ListGetInternalRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + int length; (void) Tcl_GetStringFromObj(listPtr, &length); if (length == 0) { @@ -739,7 +719,7 @@ Tcl_ListObjAppendElement( } } if (isShared || needGrow) { - Tcl_Obj **dst, **src = &listRepPtr->elements; + Tcl_Obj **dst, **src = listRepPtr->elements; /* * Either we have a shared internalrep and we must copy to write, or we @@ -767,7 +747,7 @@ Tcl_ListObjAppendElement( return TCL_ERROR; } - dst = &newPtr->elements; + dst = newPtr->elements; newPtr->refCount++; newPtr->canonicalFlag = listRepPtr->canonicalFlag; newPtr->elemCount = listRepPtr->elemCount; @@ -803,7 +783,7 @@ Tcl_ListObjAppendElement( * the ref count for the (now shared) objPtr. */ - *(&listRepPtr->elements + listRepPtr->elemCount) = objPtr; + listRepPtr->elements[listRepPtr->elemCount] = objPtr; Tcl_IncrRefCount(objPtr); listRepPtr->elemCount++; @@ -821,23 +801,27 @@ Tcl_ListObjAppendElement( * * Tcl_ListObjIndex -- * - * This function returns a pointer to the index'th object from the list - * referenced by listPtr. The first element has index 0. If index is - * negative or greater than or equal to the number of elements in the - * list, a NULL is returned. If listPtr is not a list object, an attempt - * will be made to convert it to a list. + * Retrieve a pointer to the element of 'listPtr' at 'index'. The index + * of the first element is 0. * - * Results: - * The return value is normally TCL_OK; in this case objPtrPtr is set to - * the Tcl_Obj pointer for the index'th list element or NULL if index is - * out of range. This object should be treated as readonly and its ref - * count is _not_ incremented; the caller must do that if it holds on to - * the reference. If listPtr does not refer to a list and can't be - * converted to one, TCL_ERROR is returned and an error message is left - * in the interpreter's result if interp is not NULL. + * Value * - * Side effects: - * listPtr will be converted, if necessary, to a list object. + * TCL_OK + * + * A pointer to the element at 'index' is stored in 'objPtrPtr'. If + * 'index' is out of range, NULL is stored in 'objPtrPtr'. This + * object should be treated as readonly and its 'refCount' is _not_ + * incremented. The caller must do that if it holds on to the + * reference. + * + * TCL_ERROR + * + * 'listPtr' is not a valid list. An an error message is left in the + * interpreter's result if 'interp' is not NULL. + * + * Effect + * + * If 'listPtr' is not already of type 'tclListType', it is converted. * *---------------------------------------------------------------------- */ @@ -853,7 +837,8 @@ Tcl_ListObjIndex( ListGetInternalRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + int length; (void) Tcl_GetStringFromObj(listPtr, &length); if (length == 0) { @@ -870,7 +855,7 @@ Tcl_ListObjIndex( if ((index < 0) || (index >= listRepPtr->elemCount)) { *objPtrPtr = NULL; } else { - *objPtrPtr = (&listRepPtr->elements)[index]; + *objPtrPtr = listRepPtr->elements[index]; } return TCL_OK; @@ -881,19 +866,20 @@ Tcl_ListObjIndex( * * Tcl_ListObjLength -- * - * This function returns the number of elements in a list object. If the - * object is not already a list object, an attempt will be made to - * convert it to one. + * Retrieve the number of elements in a list. * - * Results: - * The return value is normally TCL_OK; in this case *intPtr will be set - * to the integer count of list elements. If listPtr does not refer to a - * list object and the object can not be converted to one, TCL_ERROR is - * returned and an error message will be left in the interpreter's result - * if interp is not NULL. + * Value * - * Side effects: - * The possible conversion of the argument object to a list object. + * TCL_OK + * + * A count of list elements is stored at the address provided by + * 'intPtr'. If 'listPtr' is not already of type 'tclListPtr', it is + * converted. + * + * TCL_ERROR + * + * 'listPtr' is not a valid list. An error message will be left in + * the interpreter's result if 'interp' is not NULL. * *---------------------------------------------------------------------- */ @@ -903,13 +889,14 @@ int Tcl_ListObjLength( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listPtr, /* List object whose #elements to return. */ - int *intPtr) /* The resulting int is stored here. */ + int *intPtr) /* The resulting length is stored here. */ { List *listRepPtr; ListGetInternalRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + int length; (void) Tcl_GetStringFromObj(listPtr, &length); if (length == 0) { @@ -932,35 +919,36 @@ Tcl_ListObjLength( * * Tcl_ListObjReplace -- * - * This function replaces zero or more elements of the list referenced by - * listPtr with the objects from an (objc,objv) array. The objc elements - * of the array referenced by objv replace the count elements in listPtr - * starting at first. + * Replace values in a list. * - * If the argument first is zero or negative, it refers to the first - * element. If first is greater than or equal to the number of elements - * in the list, then no elements are deleted; the new elements are - * appended to the list. Count gives the number of elements to replace. - * If count is zero or negative then no elements are deleted; the new - * elements are simply inserted before first. + * If 'first' is zero or TCL_INDEX_NONE, it refers to the first element. If + * 'first' outside the range of elements in the list, no elements are + * deleted. * - * The argument objv refers to an array of objc pointers to the new - * elements to be added to listPtr in place of those that were deleted. - * If objv is NULL, no new elements are added. If listPtr is not a list - * object, an attempt will be made to convert it to one. + * If 'count' is zero or TCL_INDEX_NONE no elements are deleted, and any new + * elements are inserted at the beginning of the list. * - * Results: - * The return value is normally TCL_OK. If listPtr does not refer to a - * list object and can not be converted to one, TCL_ERROR is returned and - * an error message will be left in the interpreter's result if interp is - * not NULL. + * Value * - * Side effects: - * The ref counts of the objc elements in objv are incremented since the - * resulting list now refers to them. Similarly, the ref counts for - * replaced objects are decremented. listPtr is converted, if necessary, - * to a list object. listPtr's old string representation, if any, is - * freed. + * TCL_OK + * + * The first 'objc' values of 'objv' replaced 'count' elements in 'listPtr' + * starting at 'first'. If 'objc' 0, no new elements are added. + * + * TCL_ERROR + * + * 'listPtr' is not a valid list. An error message is left in the + * interpreter's result if 'interp' is not NULL. + * + * Effect + * + * If 'listPtr' is not of type 'tclListType', it is converted if possible. + * + * The 'refCount' of each element appended to the list is incremented. + * Similarly, the 'refCount' for each replaced element is decremented. + * + * If 'listPtr' is modified, any previous string representation is + * invalidated. * *---------------------------------------------------------------------- */ @@ -977,7 +965,8 @@ Tcl_ListObjReplace( { List *listRepPtr; Tcl_Obj **elemPtrs; - int needGrow, numElems, numRequired, numAfterLast, start, i, j, isShared; + int numElems, numRequired, numAfterLast, start, i, j; + int needGrow, isShared; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); @@ -1011,7 +1000,7 @@ Tcl_ListObjReplace( * Resist any temptation to optimize this case. */ - elemPtrs = &listRepPtr->elements; + elemPtrs = listRepPtr->elements; numElems = listRepPtr->elemCount; if (first < 0) { @@ -1065,7 +1054,7 @@ Tcl_ListObjReplace( if (newPtr) { listRepPtr = newPtr; ListResetInternalRep(listPtr, listRepPtr); - elemPtrs = &listRepPtr->elements; + elemPtrs = listRepPtr->elements; listRepPtr->maxElemCount = attempt; needGrow = numRequired > listRepPtr->maxElemCount; } @@ -1140,7 +1129,7 @@ Tcl_ListObjReplace( ListResetInternalRep(listPtr, listRepPtr); listRepPtr->refCount++; - elemPtrs = &listRepPtr->elements; + elemPtrs = listRepPtr->elements; if (isShared) { /* @@ -1228,22 +1217,19 @@ Tcl_ListObjReplace( * * TclLindexList -- * - * This procedure handles the 'lindex' command when objc==3. + * Implements the 'lindex' command when objc==3. * - * Results: - * Returns a pointer to the object extracted, or NULL if an error - * occurred. The returned object already includes one reference count for - * the pointer returned. + * Implemented entirely as a wrapper around 'TclLindexFlat'. Reconfigures + * the argument format into required form while taking care to manage + * shimmering so as to tend to keep the most useful internalreps + * and/or avoid the most expensive conversions. * - * Side effects: - * None. + * Value * - * Notes: - * This procedure is implemented entirely as a wrapper around - * TclLindexFlat. All it does is reconfigure the argument format into the - * form required by TclLindexFlat, while taking care to manage shimmering - * in such a way that we tend to keep the most useful internalreps and/or - * avoid the most expensive conversions. + * A pointer to the specified element, with its 'refCount' incremented, or + * NULL if an error occurred. + * + * Notes * *---------------------------------------------------------------------- */ @@ -1302,7 +1288,7 @@ TclLindexList( assert(listRepPtr != NULL); listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount, - &listRepPtr->elements); + listRepPtr->elements); Tcl_DecrRefCount(indexListCopy); return listPtr; } @@ -1310,25 +1296,20 @@ TclLindexList( /* *---------------------------------------------------------------------- * - * TclLindexFlat -- + * TclLindexFlat -- * - * This procedure is the core of the 'lindex' command, with all index - * arguments presented as a flat list. + * The core of the 'lindex' command, with all index + * arguments presented as a flat list. * - * Results: - * Returns a pointer to the object extracted, or NULL if an error - * occurred. The returned object already includes one reference count for - * the pointer returned. + * Value * - * Side effects: - * None. + * A pointer to the object extracted, with its 'refCount' incremented, or + * NULL if an error occurred. Thus, the calling code will usually do + * something like: + * + * Tcl_SetObjResult(interp, result); + * Tcl_DecrRefCount(result); * - * Notes: - * The reference count of the returned object includes one reference - * corresponding to the pointer returned. Thus, the calling code will - * usually do something like: - * Tcl_SetObjResult(interp, result); - * Tcl_DecrRefCount(result); * *---------------------------------------------------------------------- */ @@ -1404,24 +1385,17 @@ TclLindexFlat( * * TclLsetList -- * - * Core of the 'lset' command when objc == 4. Objv[2] may be either a + * The core of [lset] when objc == 4. Objv[2] may be either a * scalar index or a list of indices. * It also handles 'lpop' when given a NULL value. * - * Results: - * Returns the new value of the list variable, or NULL if there was an - * error. The returned object includes one reference count for the - * pointer returned. + * Implemented entirely as a wrapper around 'TclLindexFlat', as described + * for 'TclLindexList'. * - * Side effects: - * None. + * Value * - * Notes: - * This procedure is implemented entirely as a wrapper around - * TclLsetFlat. All it does is reconfigure the argument format into the - * form required by TclLsetFlat, while taking care to manage shimmering - * in such a way that we tend to keep the most useful internalreps and/or - * avoid the most expensive conversions. + * The new list, with the 'refCount' of 'valuPtr' incremented, or NULL if + * there was an error. * *---------------------------------------------------------------------- */ @@ -1486,36 +1460,39 @@ TclLsetList( * Core engine of the 'lset' command. * It also handles 'lpop' when given a NULL value. * - * Results: - * Returns the new value of the list variable, or NULL if an error - * occurred. The returned object includes one reference count for the - * pointer returned. + * Value * - * Side effects: - * On entry, the reference count of the variable value does not reflect - * any references held on the stack. The first action of this function is - * to determine whether the object is shared, and to duplicate it if it - * is. The reference count of the duplicate is incremented. At this - * point, the reference count will be 1 for either case, so that the - * object will appear to be unshared. - * - * If an error occurs, and the object has been duplicated, the reference - * count on the duplicate is decremented so that it is now 0: this - * dismisses any memory that was allocated by this function. - * - * If no error occurs, the reference count of the original object is - * incremented if the object has not been duplicated, and nothing is done - * to a reference count of the duplicate. Now the reference count of an - * unduplicated object is 2 (the returned pointer, plus the one stored in - * the variable). The reference count of a duplicate object is 1, - * reflecting that the returned pointer is the only active reference. The - * caller is expected to store the returned value back in the variable - * and decrement its reference count. (INST_STORE_* does exactly this.) - * - * Surgery is performed on the unshared list value to produce the result. - * TclLsetFlat maintains a linked list of Tcl_Obj's whose string + * The resulting list + * + * The 'refCount' of 'valuePtr' is incremented. If 'listPtr' was not + * duplicated, its 'refCount' is incremented. The reference count of + * an unduplicated object is therefore 2 (one for the returned pointer + * and one for the variable that holds it). The reference count of a + * duplicate object is 1, reflecting that result is the only active + * reference. The caller is expected to store the result in the + * variable and decrement its reference count. (INST_STORE_* does + * exactly this.) + * + * NULL + * + * An error occurred. If 'listPtr' was duplicated, the reference + * count on the duplicate is decremented so that it is 0, causing any + * memory allocated by this function to be freed. + * + * + * Effect + * + * On entry, the reference count of 'listPtr' does not reflect any + * references held on the stack. The first action of this function is to + * determine whether 'listPtr' is shared and to create a duplicate + * unshared copy if it is. The reference count of the duplicate is + * incremented. At this point, the reference count is 1 in either case so + * that the object is considered unshared. + * + * The unshared list is altered directly to produce the result. + * 'TclLsetFlat' maintains a linked list of 'Tcl_Obj' values whose string * representations must be spoilt by threading via 'ptr2' of the - * two-pointer internal representation. On entry to TclLsetFlat, the + * two-pointer internal representation. On entry to 'TclLsetFlat', the * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any * Tcl_Obj that has been modified is set to NULL. * @@ -1531,7 +1508,8 @@ TclLsetFlat( /* Index args. */ Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */ { - int index, result, len; + int index, len; + int result; Tcl_Obj *subListPtr, *retValuePtr, *chainPtr; Tcl_ObjInternalRep *irPtr; @@ -1724,12 +1702,12 @@ TclLsetFlat( } /* - * Store valuePtr in proper sublist and return. The -1 is to avoid a - * compiler warning (not a problem because we checked that we have a - * proper list - or something convertible to one - above). + * Store valuePtr in proper sublist and return. The TCL_INDEX_NONE is + * to avoid a compiler warning (not a problem because we checked that + * we have a proper list - or something convertible to one - above). */ - len = -1; + len = TCL_INDEX_NONE; TclListObjLengthM(NULL, subListPtr, &len); if (valuePtr == NULL) { Tcl_ListObjReplace(NULL, subListPtr, index, 1, 0, NULL); @@ -1748,26 +1726,38 @@ TclLsetFlat( * * TclListObjSetElement -- * - * Set a single element of a list to a specified value + * Set a single element of a list to a specified value. * - * Results: - * The return value is normally TCL_OK. If listPtr does not refer to a - * list object and cannot be converted to one, TCL_ERROR is returned and - * an error message will be left in the interpreter result if interp is - * not NULL. Similarly, if index designates an element outside the range - * [0..listLength-1], where listLength is the count of elements in the - * list object designated by listPtr, TCL_ERROR is returned and an error - * message is left in the interpreter result. + * It is the caller's responsibility to invalidate the string + * representation of the 'listPtr'. * - * Side effects: - * Tcl_Panic if listPtr designates a shared object. Otherwise, attempts - * to convert it to a list with a non-shared internal rep. Decrements the - * ref count of the object at the specified index within the list, - * replaces with the object designated by valuePtr, and increments the - * ref count of the replacement object. + * Value + * + * TCL_OK + * + * Success. + * + * TCL_ERROR + * + * 'listPtr' does not refer to a list object and cannot be converted + * to one. An error message will be left in the interpreter result if + * interp is not NULL. + * + * TCL_ERROR + * + * An index designates an element outside the range [0..listLength-1], + * where 'listLength' is the count of elements in the list object + * designated by 'listPtr'. An error message is left in the + * interpreter result. + * + * Effect + * + * If 'listPtr' designates a shared object, 'Tcl_Panic' is called. If + * 'listPtr' is not already of type 'tclListType', it is converted and the + * internal representation is unshared. The 'refCount' of the element at + * 'index' is decremented and replaced in the list with the 'valuePtr', + * whose 'refCount' in turn is incremented. * - * It is the caller's responsibility to invalidate the string - * representation of the object. * *---------------------------------------------------------------------- */ @@ -1797,7 +1787,8 @@ TclListObjSetElement( ListGetInternalRep(listPtr, listRepPtr); if (listRepPtr == NULL) { - int result, length; + int result; + int length; (void) Tcl_GetStringFromObj(listPtr, &length); if (length == 0) { @@ -1837,7 +1828,7 @@ TclListObjSetElement( */ if (listRepPtr->refCount > 1) { - Tcl_Obj **dst, **src = &listRepPtr->elements; + Tcl_Obj **dst, **src = listRepPtr->elements; List *newPtr = AttemptNewList(NULL, listRepPtr->maxElemCount, NULL); if (newPtr == NULL) { @@ -1850,7 +1841,7 @@ TclListObjSetElement( newPtr->elemCount = elemCount; newPtr->canonicalFlag = listRepPtr->canonicalFlag; - dst = &newPtr->elements; + dst = newPtr->elements; while (elemCount--) { *dst = *src++; Tcl_IncrRefCount(*dst++); @@ -1861,7 +1852,7 @@ TclListObjSetElement( listRepPtr = newPtr; ListResetInternalRep(listPtr, listRepPtr); } - elemPtrs = &listRepPtr->elements; + elemPtrs = listRepPtr->elements; /* * Add a reference to the new list element. @@ -1901,13 +1892,11 @@ TclListObjSetElement( * * FreeListInternalRep -- * - * Deallocate the storage associated with a list object's internal - * representation. + * Deallocate the storage associated with the internal representation of a + * a list object. * - * Results: - * None. + * Effect * - * Side effects: * Frees listPtr's List* internal representation, if no longer shared. * May decrement the ref counts of element objects, which may free them. * @@ -1924,7 +1913,7 @@ FreeListInternalRep( assert(listRepPtr != NULL); if (listRepPtr->refCount-- <= 1) { - Tcl_Obj **elemPtrs = &listRepPtr->elements; + Tcl_Obj **elemPtrs = listRepPtr->elements; int i, numElems = listRepPtr->elemCount; for (i = 0; i < numElems; i++) { @@ -1939,14 +1928,12 @@ FreeListInternalRep( * * DupListInternalRep -- * - * Initialize the internal representation of a list Tcl_Obj to share the + * Initialize the internal representation of a list 'Tcl_Obj' to share the * internal representation of an existing list object. * - * Results: - * None. + * Effect * - * Side effects: - * The reference count of the List internal rep is incremented. + * The 'refCount' of the List internal rep is incremented. * *---------------------------------------------------------------------- */ @@ -1968,16 +1955,20 @@ DupListInternalRep( * * SetListFromAny -- * - * Attempt to generate a list internal form for the Tcl object "objPtr". + * Convert any object to a list. * - * Results: - * The return value is TCL_OK or TCL_ERROR. If an error occurs during - * conversion, an error message is left in the interpreter's result - * unless "interp" is NULL. + * Value + * + * TCL_OK + * + * Success. The internal representation of 'objPtr' is set, and the type + * of 'objPtr' is 'tclListType'. + * + * TCL_ERROR + * + * An error occured during conversion. An error message is left in the + * interpreter's result if 'interp' is not NULL. * - * Side effects: - * If no error occurs, a list is stored as "objPtr"s internal - * representation. * *---------------------------------------------------------------------- */ @@ -2001,7 +1992,8 @@ SetListFromAny( if (!TclHasStringRep(objPtr) && TclHasInternalRep(objPtr, &tclDictType)) { Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; - int done, size; + int done; + int size; /* * Create the new list representation. Note that we do not need to do @@ -2023,7 +2015,7 @@ SetListFromAny( * Populate the list representation. */ - elemPtrs = &listRepPtr->elements; + elemPtrs = listRepPtr->elements; Tcl_DictObjFirst(NULL, objPtr, &search, &keyPtr, &valuePtr, &done); while (!done) { *elemPtrs++ = keyPtr; @@ -2048,7 +2040,7 @@ SetListFromAny( if (listRepPtr == NULL) { return TCL_ERROR; } - elemPtrs = &listRepPtr->elements; + elemPtrs = listRepPtr->elements; /* * Each iteration, parse and store a list element. @@ -2057,12 +2049,13 @@ SetListFromAny( while (nextElem < limit) { const char *elemStart; char *check; - int elemSize, literal; + int elemSize; + int literal; if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem, &elemStart, &nextElem, &elemSize, &literal)) { fail: - while (--elemPtrs >= &listRepPtr->elements) { + while (--elemPtrs >= listRepPtr->elements) { Tcl_DecrRefCount(*elemPtrs); } ckfree(listRepPtr); @@ -2092,7 +2085,7 @@ SetListFromAny( Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */ } - listRepPtr->elemCount = elemPtrs - &listRepPtr->elements; + listRepPtr->elemCount = elemPtrs - listRepPtr->elements; } /* @@ -2110,18 +2103,16 @@ SetListFromAny( * * UpdateStringOfList -- * - * Update the string representation for a list object. Note: This - * function does not invalidate an existing old string rep so storage - * will be lost if this has not already been done. + * Update the string representation for a list object. * - * Results: - * None. + * Any previously-exising string representation is not invalidated, so + * storage is lost if this has not been taken care of. * - * Side effects: - * The object's string is set to a valid string that results from the - * list-to-string conversion. This string will be empty if the list has - * no elements. The list internal representation should not be NULL and - * we assume it is not NULL. + * Effect + * + * The string representation of 'listPtr' is set to the resulting string. + * This string will be empty if the list has no elements. It is assumed + * that the list internal representation is not NULL. * *---------------------------------------------------------------------- */ @@ -2174,7 +2165,7 @@ UpdateStringOfList( flagPtr = (char *)ckalloc(numElems); } - elemPtrs = &listRepPtr->elements; + elemPtrs = listRepPtr->elements; for (i = 0; i < numElems; i++) { flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); elem = TclGetStringFromObj(elemPtrs[i], &length); -- cgit v0.12 From 554ed37525a85518448300c6cdfd33d7d2684425 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 14 Jul 2022 10:53:55 +0000 Subject: Same bug-fix as [b79df322a9], but then for Tcl_AppendUnicodeToObj() --- generic/tclStringObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index b9d603d..7ce1cdc 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1744,7 +1744,7 @@ Tcl_AppendUnicodeToObj( return; } - SetStringFromAny(NULL, objPtr); + SetUTF16StringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); stringPtr = stringAttemptRealloc(stringPtr, stringPtr->numChars + length); memcpy(&stringPtr->unicode[stringPtr->numChars], unicode, length); -- cgit v0.12 From c1af880cfe49e05ba4dd7d2607ba3715f1ff87c3 Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Fri, 15 Jul 2022 17:11:41 +0000 Subject: Restore FP control word on conversion of zero values. Sneak path existed that failed to restore the floating point control word when scanning a zero value. The result was that floating point rounding was incorrectly left set to 53-bit significance, round-to-even, which is incompatible with the math library from musl. --- generic/tclStrToD.c | 42 +++++++++++++++++++++++++++++------------- 1 file changed, 29 insertions(+), 13 deletions(-) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 61162d0..efff815 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1627,7 +1627,6 @@ MakeLowPrecisionDouble( int numSigDigs, /* Number of digits in the significand */ long exponent) /* Power of ten */ { - double retval; /* Value of the number. */ mp_int significandBig; /* Significand expressed as a bignum. */ /* @@ -1635,18 +1634,25 @@ MakeLowPrecisionDouble( * This causes the result of double-precision calculations to be rounded * twice: once to the precision of double-extended and then again to the * precision of double. Double-rounding introduces gratuitous errors of 1 - * ulp, so we need to change rounding mode to 53-bits. + * ulp, so we need to change rounding mode to 53-bits. We also make + * 'retval' volatile, so that it doesn't get promoted to a register. */ - - TCL_IEEE_DOUBLE_ROUNDING; + volatile double retval; /* Value of the number. */ /* - * Test for the easy cases. + * Test for zero significand, which requires explicit construction + * of -0.0. (Unary minus returns a positive zero.) */ - if (significand == 0) { return copysign(0.0, -signum); } + + /* + * Set the FP control word for 53 bits, WARNING: It must be reset + * before returning. + */ + TCL_IEEE_DOUBLE_ROUNDING; + if (numSigDigs <= QUICK_MAX) { if (exponent >= 0) { if (exponent <= mmaxpow) { @@ -1744,7 +1750,6 @@ MakeHighPrecisionDouble( int numSigDigs, /* Number of significant digits */ long exponent) /* Power of 10 by which to multiply */ { - double retval; int machexp; /* Machine exponent of a power of 10. */ /* @@ -1752,19 +1757,30 @@ MakeHighPrecisionDouble( * This causes the result of double-precision calculations to be rounded * twice: once to the precision of double-extended and then again to the * precision of double. Double-rounding introduces gratuitous errors of 1 - * ulp, so we need to change rounding mode to 53-bits. + * ulp, so we need to change rounding mode to 53-bits. We also make + * 'retval' volatile to make sure that it doesn't get promoted to a + * register. */ + volatile double retval; + /* + * A zero significand requires explicit construction of -0.0. + * (Unary minus returns positive zero.) + */ + if (mp_iszero(significand)) { + return copysign(0.0, -signum); + } + + /* + * Set the 53-bit rounding mode. WARNING: It must be reset before + * returning. + */ TCL_IEEE_DOUBLE_ROUNDING; /* - * Quick checks for zero, and over/underflow. Be careful to avoid + * Make quick checks for over/underflow. Be careful to avoid * integer overflow when calculating with 'exponent'. */ - - if (mp_iszero(significand)) { - return copysign(0.0, -signum); - } if (exponent >= 0 && exponent-1 > maxDigits-numSigDigs) { retval = HUGE_VAL; goto returnValue; -- cgit v0.12 From b0dd51b115eda106d6dd034f4867d446d28f4e1c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 18 Jul 2022 11:07:59 +0000 Subject: Only use -DBUILD_tcl for shared/static library --- generic/tcl.h | 2 +- unix/Makefile.in | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index d99e9fa..ca68eaa 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2379,7 +2379,7 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp, #if defined(_WIN32) TCL_NORETURN void Tcl_ConsolePanic(const char *format, ...); #else -# define Tcl_ConsolePanic ((Tcl_PanicProc *)0) +# define Tcl_ConsolePanic ((Tcl_PanicProc *)NULL) #endif #ifdef USE_TCL_STUBS diff --git a/unix/Makefile.in b/unix/Makefile.in index d0a9d86..28fa446 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -176,7 +176,7 @@ NATIVE_TCLSH = @TCLSH_PROG@ STLIB_LD = @STLIB_LD@ SHLIB_LD = @SHLIB_LD@ -SHLIB_CFLAGS = @SHLIB_CFLAGS@ -DBUILD_tcl +SHLIB_CFLAGS = @SHLIB_CFLAGS@ SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ SHLIB_LD_FLAGS = @SHLIB_LD_FLAGS@ TCL_SHLIB_LD_EXTRAS = @TCL_SHLIB_LD_EXTRAS@ @@ -278,12 +278,12 @@ VALGRINDARGS = --tool=memcheck --num-callers=24 \ STUB_CC_SWITCHES = -I"${BUILD_DIR}" -I${UNIX_DIR} -I${GENERIC_DIR} -I${TOMMATH_DIR} \ ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ - ${AC_FLAGS} ${ENV_FLAGS} ${EXTRA_CFLAGS} \ - @EXTRA_CC_SWITCHES@ + ${AC_FLAGS} ${ENV_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@ \ + ${NO_DEPRECATED_FLAGS} -DMP_FIXED_CUTOFFS -DMP_NO_STDINT -CC_SWITCHES = $(STUB_CC_SWITCHES) ${NO_DEPRECATED_FLAGS} -DMP_FIXED_CUTOFFS -DMP_NO_STDINT +CC_SWITCHES = $(STUB_CC_SWITCHES) -DBUILD_tcl -APP_CC_SWITCHES = $(CC_SWITCHES) @EXTRA_APP_CC_SWITCHES@ +APP_CC_SWITCHES = $(STUB_CC_SWITCHES) @EXTRA_APP_CC_SWITCHES@ LIBS = @TCL_LIBS@ -- cgit v0.12 From 004fe2d35203d7d11d592e8808c83f8a04dfeb31 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 18 Jul 2022 11:56:23 +0000 Subject: Updste stdlib.h (add missing functions). Restructure tclAppInit.c --- compat/stdlib.h | 14 +++++++++----- unix/tclAppInit.c | 10 ++++++---- win/tclAppInit.c | 26 ++++++++++++++------------ 3 files changed, 29 insertions(+), 21 deletions(-) diff --git a/compat/stdlib.h b/compat/stdlib.h index bb0f133..2f7eaf4 100644 --- a/compat/stdlib.h +++ b/compat/stdlib.h @@ -21,14 +21,18 @@ extern void abort(void); extern double atof(const char *string); extern int atoi(const char *string); extern long atol(const char *string); -extern char * calloc(unsigned int numElements, unsigned int size); +extern void * calloc(unsigned long numElements, unsigned long size); extern void exit(int status); -extern int free(char *blockPtr); +extern void free(void *blockPtr); extern char * getenv(const char *name); -extern char * malloc(unsigned int numBytes); -extern void qsort(void *base, int n, int size, int (*compar)( +extern void * malloc(unsigned long numBytes); +extern void qsort(void *base, unsigned long n, unsigned long size, int (*compar)( const void *element1, const void *element2)); -extern char * realloc(char *ptr, unsigned int numBytes); +extern void * realloc(void *ptr, unsigned long numBytes); +extern char * realpath(const char *path, char *resolved_path); +extern int mkstemps(char *templ, int suffixlen); +extern int mkstemp(char *templ); +extern char * mkdtemp(char *templ); extern long strtol(const char *string, char **endPtr, int base); extern unsigned long strtoul(const char *string, char **endPtr, int base); diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 3f69f45..51a4cb5 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -12,13 +12,15 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#if defined(BUILD_tcl) || defined(USE_TCL_STUBS) -#error "Don't build with BUILD_tcl/USE_TCL_STUBS!" -#endif #include "tcl.h" -#if TCL_MAJOR_VERSION < 9 && TCL_MINOR_VERSION < 7 +#if TCL_MAJOR_VERSION < 9 +# if defined(BUILD_tcl) || defined(USE_TCL_STUBS) +# error "Don't build with BUILD_tcl/USE_TCL_STUBS!" +# endif +# if TCL_MINOR_VERSION < 7 # define Tcl_LibraryInitProc Tcl_PackageInitProc # define Tcl_StaticLibrary Tcl_StaticPackage +# endif #endif #ifdef TCL_TEST diff --git a/win/tclAppInit.c b/win/tclAppInit.c index 4dd6c6e..53ac274 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -14,21 +14,15 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#if defined(BUILD_tcl) || defined(USE_TCL_STUBS) -#error "Don't build with BUILD_tcl/USE_TCL_STUBS!" -#endif #include "tcl.h" -#define WIN32_LEAN_AND_MEAN -#define STRICT /* See MSDN Article Q83456 */ -#include -#undef STRICT -#undef WIN32_LEAN_AND_MEAN -#include -#include -#include -#if TCL_MAJOR_VERSION < 9 && TCL_MINOR_VERSION < 7 +#if TCL_MAJOR_VERSION < 9 +# if defined(BUILD_tcl) || defined(USE_TCL_STUBS) +# error "Don't build with BUILD_tcl/USE_TCL_STUBS!" +# endif +# if TCL_MINOR_VERSION < 7 # define Tcl_LibraryInitProc Tcl_PackageInitProc # define Tcl_StaticLibrary Tcl_StaticPackage +# endif #endif #ifdef TCL_TEST @@ -42,6 +36,14 @@ extern Tcl_LibraryInitProc Dde_Init; extern Tcl_LibraryInitProc Dde_SafeInit; #endif +#define WIN32_LEAN_AND_MEAN +#define STRICT /* See MSDN Article Q83456 */ +#include +#undef STRICT +#undef WIN32_LEAN_AND_MEAN +#include +#include +#include #if defined(__GNUC__) || defined(TCL_BROKEN_MAINARGS) int _CRT_glob = 0; #endif /* __GNUC__ || TCL_BROKEN_MAINARGS */ -- cgit v0.12 From 850b3e24a87d95e1efbabbc401cf1412078e584c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 19 Jul 2022 08:35:05 +0000 Subject: Make a start converting -1 -> TCL_INDEX_NONE where appropriate --- macosx/tclMacOSXFCmd.c | 12 ++++++------ unix/tclAppInit.c | 10 +++++----- unix/tclLoadDl.c | 10 +++++----- unix/tclLoadDyld.c | 10 +++++----- unix/tclLoadNext.c | 2 +- unix/tclLoadOSF.c | 2 +- unix/tclLoadShl.c | 4 ++-- unix/tclUnixChan.c | 8 +++----- unix/tclUnixFCmd.c | 22 +++++++++++----------- unix/tclUnixFile.c | 28 ++++++++++++++-------------- unix/tclUnixInit.c | 36 ++++++++++++++++++------------------ unix/tclUnixPipe.c | 10 +++++----- unix/tclUnixSock.c | 10 +++++----- win/tclAppInit.c | 6 +++--- win/tclWinFCmd.c | 22 +++++++++++----------- win/tclWinFile.c | 22 +++++++++++----------- win/tclWinInit.c | 10 +++++----- win/tclWinLoad.c | 2 +- win/tclWinPipe.c | 12 ++++++------ win/tclWinSerial.c | 10 +++++----- win/tclWinSock.c | 4 ++-- 21 files changed, 125 insertions(+), 127 deletions(-) diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index 1717c3c..02e57f1 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -344,8 +344,8 @@ TclMacOSXSetFileAttribute( */ Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, native, -1); - Tcl_DStringAppend(&ds, _PATH_RSRCFORKSPEC, -1); + Tcl_DStringAppend(&ds, native, TCL_INDEX_NONE); + Tcl_DStringAppend(&ds, _PATH_RSRCFORKSPEC, TCL_INDEX_NONE); result = truncate(Tcl_DStringValue(&ds), 0); if (result != 0) { @@ -459,11 +459,11 @@ TclMacOSXCopyFileAttributes( */ Tcl_DStringInit(&srcBuf); - Tcl_DStringAppend(&srcBuf, src, -1); - Tcl_DStringAppend(&srcBuf, _PATH_RSRCFORKSPEC, -1); + Tcl_DStringAppend(&srcBuf, src, TCL_INDEX_NONE); + Tcl_DStringAppend(&srcBuf, _PATH_RSRCFORKSPEC, TCL_INDEX_NONE); Tcl_DStringInit(&dstBuf); - Tcl_DStringAppend(&dstBuf, dst, -1); - Tcl_DStringAppend(&dstBuf, _PATH_RSRCFORKSPEC, -1); + Tcl_DStringAppend(&dstBuf, dst, TCL_INDEX_NONE); + Tcl_DStringAppend(&dstBuf, _PATH_RSRCFORKSPEC, TCL_INDEX_NONE); /* * Do the copy. diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 552f9e4..29ca4e4 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -88,7 +88,7 @@ main( TclZipfs_AppHook(&argc, &argv); #endif - Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); + Tcl_Main((size_t)argc, argv, TCL_LOCAL_APPINIT); return 0; /* Needed only to prevent compiler warning. */ } @@ -157,11 +157,11 @@ Tcl_AppInit( */ #ifdef DJGPP - (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, - Tcl_NewStringObj("~/tclsh.rc", -1), TCL_GLOBAL_ONLY); + (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", TCL_INDEX_NONE), NULL, + Tcl_NewStringObj("~/tclsh.rc", TCL_INDEX_NONE), TCL_GLOBAL_ONLY); #else - (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, - Tcl_NewStringObj("~/.tclshrc", -1), TCL_GLOBAL_ONLY); + (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", TCL_INDEX_NONE), NULL, + Tcl_NewStringObj("~/.tclshrc", TCL_INDEX_NONE), TCL_GLOBAL_ONLY); #endif return TCL_OK; diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c index 342dff6..5c19ea3 100644 --- a/unix/tclLoadDl.c +++ b/unix/tclLoadDl.c @@ -108,7 +108,7 @@ TclpDlopen( Tcl_DString ds; const char *fileName = Tcl_GetString(pathPtr); - native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds); /* * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070] */ @@ -179,12 +179,12 @@ FindSymbol( * the underscore. */ - native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, symbol, TCL_INDEX_NONE, &ds); proc = dlsym(handle, native); /* INTL: Native. */ if (proc == NULL) { Tcl_DStringInit(&newName); TclDStringAppendLiteral(&newName, "_"); - native = Tcl_DStringAppend(&newName, native, -1); + native = Tcl_DStringAppend(&newName, native, TCL_INDEX_NONE); proc = dlsym(handle, native); /* INTL: Native. */ Tcl_DStringFree(&newName); } @@ -194,8 +194,8 @@ FindSymbol( sprintf(buf, "%d", Tcl_DStringLength(&ds)); Tcl_DStringInit(&newName); TclDStringAppendLiteral(&newName, "__Z"); - Tcl_DStringAppend(&newName, buf, -1); - Tcl_DStringAppend(&newName, Tcl_DStringValue(&ds), -1); + Tcl_DStringAppend(&newName, buf, TCL_INDEX_NONE); + Tcl_DStringAppend(&newName, Tcl_DStringValue(&ds), TCL_INDEX_NONE); TclDStringAppendLiteral(&newName, "P10Tcl_Interp"); native = Tcl_DStringValue(&newName); proc = dlsym(handle, native + 1); /* INTL: Native. */ diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c index 7cd48f2..854d4bd 100644 --- a/unix/tclLoadDyld.c +++ b/unix/tclLoadDyld.c @@ -185,7 +185,7 @@ TclpDlopen( nativePath = (const char *)Tcl_FSGetNativePath(pathPtr); nativeFileName = Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr), - -1, &ds); + TCL_INDEX_NONE, &ds); #if TCL_DYLD_USE_DLFCN /* @@ -296,7 +296,7 @@ TclpDlopen( TclNewObj(errObj); if (errMsg != NULL) { - Tcl_AppendToObj(errObj, errMsg, -1); + Tcl_AppendToObj(errObj, errMsg, TCL_INDEX_NONE); } #if TCL_DYLD_USE_NSMODULE if (objFileImageErrMsg) { @@ -341,7 +341,7 @@ FindSymbol( Tcl_DString ds; const char *native; - native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, symbol, TCL_INDEX_NONE, &ds); if (dyldLoadHandle->dlHandle) { #if TCL_DYLD_USE_DLFCN proc = (Tcl_LibraryInitProc *)dlsym(dyldLoadHandle->dlHandle, native); @@ -360,7 +360,7 @@ FindSymbol( Tcl_DStringInit(&newName); TclDStringAppendLiteral(&newName, "_"); - native = Tcl_DStringAppend(&newName, native, -1); + native = Tcl_DStringAppend(&newName, native, TCL_INDEX_NONE); if (dyldLoadHandle->dyldLibHeader) { nsSymbol = NSLookupSymbolInImage(dyldLoadHandle->dyldLibHeader, native, NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW | @@ -656,7 +656,7 @@ TclpLoadMemory( const char *errorName, *errMsg; NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg); - Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, TCL_INDEX_NONE)); return TCL_ERROR; } diff --git a/unix/tclLoadNext.c b/unix/tclLoadNext.c index 2055210..dc827fc 100644 --- a/unix/tclLoadNext.c +++ b/unix/tclLoadNext.c @@ -83,7 +83,7 @@ TclpDlopen( Tcl_DString ds; - native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds); files = {native,NULL}; result = rld_load(errorStream, &header, files, NULL); Tcl_DStringFree(&ds); diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c index bb58871..03698fa 100644 --- a/unix/tclLoadOSF.c +++ b/unix/tclLoadOSF.c @@ -100,7 +100,7 @@ TclpDlopen( Tcl_DString ds; - native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds); lm = (Tcl_LibraryInitProc *) load(native, LDR_NOFLAGS); Tcl_DStringFree(&ds); } diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c index 5bf97eb..5cde183 100644 --- a/unix/tclLoadShl.c +++ b/unix/tclLoadShl.c @@ -86,7 +86,7 @@ TclpDlopen( Tcl_DString ds; - native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, fileName, TCL_INDEX_NONE, &ds); handle = shl_load(native, BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L); Tcl_DStringFree(&ds); } @@ -140,7 +140,7 @@ FindSymbol( (void *) &proc) != 0) { Tcl_DStringInit(&newName); TclDStringAppendLiteral(&newName, "_"); - Tcl_DStringAppend(&newName, symbol, -1); + Tcl_DStringAppend(&newName, symbol, TCL_INDEX_NONE); if (shl_findsym(&handle, Tcl_DStringValue(&newName), (short) TYPE_PROCEDURE, (void *) &proc) != 0) { proc = NULL; diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 4cb9af0..22e9876 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -1860,12 +1860,11 @@ TclpGetDefaultStdChannel( * Some #def's to make the code a little clearer! */ -#define ZERO_OFFSET ((Tcl_SeekOffset) 0) #define ERROR_OFFSET ((Tcl_SeekOffset) -1) switch (type) { case TCL_STDIN: - if ((TclOSseek(0, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) + if ((TclOSseek(0, 0, SEEK_CUR) == ERROR_OFFSET) && (errno == EBADF)) { return NULL; } @@ -1874,7 +1873,7 @@ TclpGetDefaultStdChannel( bufMode = "line"; break; case TCL_STDOUT: - if ((TclOSseek(1, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) + if ((TclOSseek(1, 0, SEEK_CUR) == ERROR_OFFSET) && (errno == EBADF)) { return NULL; } @@ -1883,7 +1882,7 @@ TclpGetDefaultStdChannel( bufMode = "line"; break; case TCL_STDERR: - if ((TclOSseek(2, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) + if ((TclOSseek(2, 0, SEEK_CUR) == ERROR_OFFSET) && (errno == EBADF)) { return NULL; } @@ -1896,7 +1895,6 @@ TclpGetDefaultStdChannel( break; } -#undef ZERO_OFFSET #undef ERROR_OFFSET channel = Tcl_MakeFileChannel(INT2PTR(fd), mode); diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index a5d6a87..818209d 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -779,7 +779,7 @@ TclpObjCopyDirectory( Tcl_DStringFree(&dstString); if (ret != TCL_OK) { - *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), TCL_INDEX_NONE); Tcl_DStringFree(&ds); Tcl_IncrRefCount(*errorPtr); } @@ -833,7 +833,7 @@ TclpObjRemoveDirectory( Tcl_DStringFree(&pathString); if (ret != TCL_OK) { - *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), TCL_INDEX_NONE); Tcl_DStringFree(&ds); Tcl_IncrRefCount(*errorPtr); } @@ -883,7 +883,7 @@ DoRemoveDirectory( result = TCL_OK; if ((errno != EEXIST) || (recursive == 0)) { if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, path, -1, errorPtr); + Tcl_ExternalToUtfDString(NULL, path, TCL_INDEX_NONE, errorPtr); } result = TCL_ERROR; } @@ -1015,9 +1015,9 @@ TraverseUnixTree( * Append name after slash, and recurse on the file. */ - Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, -1); + Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, TCL_INDEX_NONE); if (targetPtr != NULL) { - Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, -1); + Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, TCL_INDEX_NONE); } result = TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind); @@ -1132,7 +1132,7 @@ TraverseUnixTree( end: if (errfile != NULL) { if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, errfile, -1, errorPtr); + Tcl_ExternalToUtfDString(NULL, errfile, TCL_INDEX_NONE, errorPtr); } result = TCL_ERROR; } @@ -1368,8 +1368,8 @@ GetGroupAttribute( Tcl_DString ds; const char *utf; - utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds); - *attributePtrPtr = Tcl_NewStringObj(utf, -1); + utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, TCL_INDEX_NONE, &ds); + *attributePtrPtr = Tcl_NewStringObj(utf, TCL_INDEX_NONE); Tcl_DStringFree(&ds); } return TCL_OK; @@ -1421,7 +1421,7 @@ GetOwnerAttribute( } else { Tcl_DString ds; - (void) Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds); + (void) Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, TCL_INDEX_NONE, &ds); *attributePtrPtr = TclDStringToObj(&ds); } return TCL_OK; @@ -2176,7 +2176,7 @@ TclUnixOpenTemporaryFile( Tcl_UtfToExternalDString(NULL, string, dirObj->length, &templ); } else { Tcl_DStringInit(&templ); - Tcl_DStringAppend(&templ, DefaultTempDir(), -1); /* INTL: native */ + Tcl_DStringAppend(&templ, DefaultTempDir(), TCL_INDEX_NONE); /* INTL: native */ } TclDStringAppendLiteral(&templ, "/"); @@ -2301,7 +2301,7 @@ TclpCreateTemporaryDirectory( Tcl_UtfToExternalDString(NULL, string, dirObj->length, &templ); } else { Tcl_DStringInit(&templ); - Tcl_DStringAppend(&templ, DefaultTempDir(), -1); /* INTL: native */ + Tcl_DStringAppend(&templ, DefaultTempDir(), TCL_INDEX_NONE); /* INTL: native */ } if (Tcl_DStringValue(&templ)[Tcl_DStringLength(&templ) - 1] != '/') { diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 998614d..d1b656b 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -119,7 +119,7 @@ TclpFindExecutable( TclDStringAppendLiteral(&buffer, "/"); } } - name = Tcl_DStringAppend(&buffer, argv0, -1); + name = Tcl_DStringAppend(&buffer, argv0, TCL_INDEX_NONE); /* * INTL: The following calls to access() and stat() should not be @@ -155,9 +155,9 @@ TclpFindExecutable( #endif { encoding = Tcl_GetEncoding(NULL, NULL); - Tcl_ExternalToUtfDString(encoding, name, -1, &utfName); + Tcl_ExternalToUtfDString(encoding, name, TCL_INDEX_NONE, &utfName); TclSetObjNameOfExecutable( - Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding); + Tcl_NewStringObj(Tcl_DStringValue(&utfName), TCL_INDEX_NONE), encoding); Tcl_DStringFree(&utfName); goto done; } @@ -178,7 +178,7 @@ TclpFindExecutable( } Tcl_DStringInit(&nameString); - Tcl_DStringAppend(&nameString, name, -1); + Tcl_DStringAppend(&nameString, name, TCL_INDEX_NONE); Tcl_DStringFree(&buffer); Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&cwd), @@ -191,10 +191,10 @@ TclpFindExecutable( Tcl_DStringFree(&nameString); encoding = Tcl_GetEncoding(NULL, NULL); - Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1, + Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), TCL_INDEX_NONE, &utfName); TclSetObjNameOfExecutable( - Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding); + Tcl_NewStringObj(Tcl_DStringValue(&utfName), TCL_INDEX_NONE), encoding); Tcl_DStringFree(&utfName); done: @@ -307,7 +307,7 @@ TclpMatchInDirectory( * Now open the directory for reading and iterate over the contents. */ - native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, dirName, TCL_INDEX_NONE, &ds); if ((TclOSstat(native, &statBuf) != 0) /* INTL: Native. */ || !S_ISDIR(statBuf.st_mode)) { @@ -371,14 +371,14 @@ TclpMatchInDirectory( * and pattern. If so, add the file to the result. */ - utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, + utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, TCL_INDEX_NONE, &utfDs); if (Tcl_StringCaseMatch(utfname, pattern, 0)) { int typeOk = 1; if (types != NULL) { Tcl_DStringSetLength(&ds, nativeDirLen); - native = Tcl_DStringAppend(&ds, entryPtr->d_name, -1); + native = Tcl_DStringAppend(&ds, entryPtr->d_name, TCL_INDEX_NONE); matchResult = NativeMatchType(interp, native, entryPtr->d_name, types); typeOk = (matchResult == 1); @@ -598,7 +598,7 @@ TclpGetUserHome( { struct passwd *pwPtr; Tcl_DString ds; - const char *native = Tcl_UtfToExternalDString(NULL, name, -1, &ds); + const char *native = Tcl_UtfToExternalDString(NULL, name, TCL_INDEX_NONE, &ds); pwPtr = TclpGetPwNam(native); /* INTL: Native. */ Tcl_DStringFree(&ds); @@ -606,7 +606,7 @@ TclpGetUserHome( if (pwPtr == NULL) { return NULL; } - Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, -1, bufferPtr); + Tcl_ExternalToUtfDString(NULL, pwPtr->pw_dir, TCL_INDEX_NONE, bufferPtr); return Tcl_DStringValue(bufferPtr); } @@ -785,7 +785,7 @@ TclpGetCwd( } return NULL; } - return Tcl_ExternalToUtfDString(NULL, buffer, -1, bufferPtr); + return Tcl_ExternalToUtfDString(NULL, buffer, TCL_INDEX_NONE, bufferPtr); } /* @@ -820,7 +820,7 @@ TclpReadlink( const char *native; Tcl_DString ds; - native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, path, TCL_INDEX_NONE, &ds); length = readlink(native, link, sizeof(link)); /* INTL: Native. */ Tcl_DStringFree(&ds); @@ -1061,7 +1061,7 @@ TclpNativeToNormalized( { Tcl_DString ds; - Tcl_ExternalToUtfDString(NULL, (const char *) clientData, -1, &ds); + Tcl_ExternalToUtfDString(NULL, (const char *) clientData, TCL_INDEX_NONE, &ds); return TclDStringToObj(&ds); } diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index c480a56..21910e1 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -369,13 +369,13 @@ TclpInitPlatform(void) * Make sure, that the standard FDs exist. [Bug 772288] */ - if (TclOSseek(0, (Tcl_SeekOffset) 0, SEEK_CUR) == -1 && errno == EBADF) { + if (TclOSseek(0, 0, SEEK_CUR) == -1 && errno == EBADF) { open("/dev/null", O_RDONLY); } - if (TclOSseek(1, (Tcl_SeekOffset) 0, SEEK_CUR) == -1 && errno == EBADF) { + if (TclOSseek(1, 0, SEEK_CUR) == -1 && errno == EBADF) { open("/dev/null", O_WRONLY); } - if (TclOSseek(2, (Tcl_SeekOffset) 0, SEEK_CUR) == -1 && errno == EBADF) { + if (TclOSseek(2, 0, SEEK_CUR) == -1 && errno == EBADF) { open("/dev/null", O_WRONLY); } @@ -473,7 +473,7 @@ TclpInitLibraryPath( */ str = getenv("TCL_LIBRARY"); /* INTL: Native. */ - Tcl_ExternalToUtfDString(NULL, str, -1, &buffer); + Tcl_ExternalToUtfDString(NULL, str, TCL_INDEX_NONE, &buffer); str = Tcl_DStringValue(&buffer); if ((str != NULL) && (str[0] != '\0')) { @@ -496,7 +496,7 @@ TclpInitLibraryPath( * If TCL_LIBRARY is set, search there. */ - Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_NewStringObj(str, -1)); + Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_NewStringObj(str, TCL_INDEX_NONE)); Tcl_SplitPath(str, &pathc, &pathv); if ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc-1]) != 0)) { @@ -537,7 +537,7 @@ TclpInitLibraryPath( str = defaultLibraryDir; } if (str[0] != '\0') { - objPtr = Tcl_NewStringObj(str, -1); + objPtr = Tcl_NewStringObj(str, TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); } } @@ -635,13 +635,13 @@ Tcl_GetEncodingNameFromEnvironment( */ Tcl_DStringInit(&ds); - encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), -1); + encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), TCL_INDEX_NONE); Tcl_UtfToLower(Tcl_DStringValue(&ds)); knownEncoding = SearchKnownEncodings(encoding); if (knownEncoding != NULL) { - Tcl_DStringAppend(bufPtr, knownEncoding, -1); + Tcl_DStringAppend(bufPtr, knownEncoding, TCL_INDEX_NONE); } else if (NULL != Tcl_GetEncoding(NULL, encoding)) { - Tcl_DStringAppend(bufPtr, encoding, -1); + Tcl_DStringAppend(bufPtr, encoding, TCL_INDEX_NONE); } Tcl_DStringFree(&ds); if (Tcl_DStringLength(bufPtr)) { @@ -673,14 +673,14 @@ Tcl_GetEncodingNameFromEnvironment( Tcl_DStringInit(&ds); p = encoding; - encoding = Tcl_DStringAppend(&ds, p, -1); + encoding = Tcl_DStringAppend(&ds, p, TCL_INDEX_NONE); Tcl_UtfToLower(Tcl_DStringValue(&ds)); knownEncoding = SearchKnownEncodings(encoding); if (knownEncoding != NULL) { - Tcl_DStringAppend(bufPtr, knownEncoding, -1); + Tcl_DStringAppend(bufPtr, knownEncoding, TCL_INDEX_NONE); } else if (NULL != Tcl_GetEncoding(NULL, encoding)) { - Tcl_DStringAppend(bufPtr, encoding, -1); + Tcl_DStringAppend(bufPtr, encoding, TCL_INDEX_NONE); } if (Tcl_DStringLength(bufPtr)) { Tcl_DStringFree(&ds); @@ -701,9 +701,9 @@ Tcl_GetEncodingNameFromEnvironment( if (*p != '\0') { knownEncoding = SearchKnownEncodings(p); if (knownEncoding != NULL) { - Tcl_DStringAppend(bufPtr, knownEncoding, -1); + Tcl_DStringAppend(bufPtr, knownEncoding, TCL_INDEX_NONE); } else if (NULL != Tcl_GetEncoding(NULL, p)) { - Tcl_DStringAppend(bufPtr, p, -1); + Tcl_DStringAppend(bufPtr, p, TCL_INDEX_NONE); } } Tcl_DStringFree(&ds); @@ -711,7 +711,7 @@ Tcl_GetEncodingNameFromEnvironment( return Tcl_DStringValue(bufPtr); } } - return Tcl_DStringAppend(bufPtr, TCL_DEFAULT_ENCODING, -1); + return Tcl_DStringAppend(bufPtr, TCL_DEFAULT_ENCODING, TCL_INDEX_NONE); } /* @@ -901,7 +901,7 @@ TclpSetVariables( unameOK = 1; - native = Tcl_ExternalToUtfDString(NULL, name.sysname, -1, &ds); + native = Tcl_ExternalToUtfDString(NULL, name.sysname, TCL_INDEX_NONE, &ds); Tcl_SetVar2(interp, "tcl_platform", "os", native, TCL_GLOBAL_ONLY); Tcl_DStringFree(&ds); @@ -964,7 +964,7 @@ TclpSetVariables( user = ""; Tcl_DStringInit(&ds); /* ensure cleanliness */ } else { - user = Tcl_ExternalToUtfDString(NULL, pwEnt->pw_name, -1, &ds); + user = Tcl_ExternalToUtfDString(NULL, pwEnt->pw_name, TCL_INDEX_NONE, &ds); } Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY); @@ -1013,7 +1013,7 @@ TclpFindVariable( Tcl_DStringInit(&envString); for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) { - p1 = Tcl_ExternalToUtfDString(NULL, env, -1, &envString); + p1 = Tcl_ExternalToUtfDString(NULL, env, TCL_INDEX_NONE, &envString); p2 = name; for (; *p2 == *p1; p1++, p2++) { diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index e7199bc..c53360a 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -141,7 +141,7 @@ TclpOpenFile( const char *native; Tcl_DString ds; - native = Tcl_UtfToExternalDString(NULL, fname, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, fname, TCL_INDEX_NONE, &ds); fd = TclOSopen(native, mode, 0666); /* INTL: Native. */ Tcl_DStringFree(&ds); if (fd != -1) { @@ -153,7 +153,7 @@ TclpOpenFile( */ if ((mode & O_WRONLY) && !(mode & O_APPEND)) { - TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_END); + TclOSseek(fd, 0, SEEK_END); } /* @@ -198,14 +198,14 @@ TclpCreateTempFile( Tcl_DString dstring; char *native; - native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring); + native = Tcl_UtfToExternalDString(NULL, contents, TCL_INDEX_NONE, &dstring); if (write(fd, native, Tcl_DStringLength(&dstring)) == -1) { close(fd); Tcl_DStringFree(&dstring); return NULL; } Tcl_DStringFree(&dstring); - TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_SET); + TclOSseek(fd, 0, SEEK_SET); } return MakeFile(fd); } @@ -436,7 +436,7 @@ TclpCreateProcess( newArgv = (char **)TclStackAlloc(interp, (argc+1) * sizeof(char *)); newArgv[argc] = NULL; for (i = 0; i < argc; i++) { - newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]); + newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], TCL_INDEX_NONE, &dsArray[i]); } #ifdef USE_VFORK diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 91d84f3..d2068c3 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -873,7 +873,7 @@ TcpGetOptionProc( errno = err; } if (errno != 0) { - Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(errno), -1); + Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(errno), TCL_INDEX_NONE); } return TCL_OK; } @@ -881,7 +881,7 @@ TcpGetOptionProc( if ((len > 1) && (optionName[1] == 'c') && (strncmp(optionName, "-connecting", len) == 0)) { Tcl_DStringAppend(dsPtr, - GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT) ? "1" : "0", -1); + GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT) ? "1" : "0", TCL_INDEX_NONE); return TCL_OK; } @@ -1769,13 +1769,13 @@ Tcl_OpenTcpServerEx( return statePtr->channel; } if (interp != NULL) { - Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", -1); + Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", TCL_INDEX_NONE); if (errorMsg == NULL) { errno = my_errno; - Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), -1); + Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), TCL_INDEX_NONE); } else { - Tcl_AppendToObj(errorObj, errorMsg, -1); + Tcl_AppendToObj(errorObj, errorMsg, TCL_INDEX_NONE); } Tcl_SetObjResult(interp, errorObj); } diff --git a/win/tclAppInit.c b/win/tclAppInit.c index be70492..eaa4fb3 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -136,7 +136,7 @@ _tmain( TclZipfs_AppHook(&argc, &argv); #endif - Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); + Tcl_Main((size_t)argc, argv, TCL_LOCAL_APPINIT); return 0; /* Needed only to prevent compiler warning. */ } @@ -210,8 +210,8 @@ Tcl_AppInit( * user-specific startup file will be run under any conditions. */ - (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, - Tcl_NewStringObj("~/tclshrc.tcl", -1), TCL_GLOBAL_ONLY); + Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", TCL_INDEX_NONE), NULL, + Tcl_NewStringObj("~/tclshrc.tcl", TCL_INDEX_NONE), TCL_GLOBAL_ONLY); return TCL_OK; } diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 3f6d7f4..2ca041b 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -330,8 +330,8 @@ DoRenameFile( Tcl_DStringInit(&srcString); Tcl_DStringInit(&dstString); - src = Tcl_WCharToUtfDString(nativeSrcPath, -1, &srcString); - dst = Tcl_WCharToUtfDString(nativeDstPath, -1, &dstString); + src = Tcl_WCharToUtfDString(nativeSrcPath, TCL_INDEX_NONE, &srcString); + dst = Tcl_WCharToUtfDString(nativeDstPath, TCL_INDEX_NONE, &dstString); /* * Check whether the destination path is actually inside the @@ -929,7 +929,7 @@ TclpObjCopyDirectory( } else if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normDestPtr))) { *errorPtr = destPathPtr; } else { - *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), TCL_INDEX_NONE); } Tcl_DStringFree(&ds); Tcl_IncrRefCount(*errorPtr); @@ -1117,7 +1117,7 @@ DoRemoveJustDirectory( char *p; Tcl_DStringInit(errorPtr); - p = Tcl_WCharToUtfDString(nativePath, -1, errorPtr); + p = Tcl_WCharToUtfDString(nativePath, TCL_INDEX_NONE, errorPtr); for (; *p; ++p) { if (*p == '\\') *p = '/'; } @@ -1332,7 +1332,7 @@ TraverseWinTree( Tcl_WinConvertError(GetLastError()); if (errorPtr != NULL) { Tcl_DStringInit(errorPtr); - Tcl_WCharToUtfDString(nativeErrfile, -1, errorPtr); + Tcl_WCharToUtfDString(nativeErrfile, TCL_INDEX_NONE, errorPtr); } result = TCL_ERROR; } @@ -1398,7 +1398,7 @@ TraversalCopy( if (errorPtr != NULL) { Tcl_DStringInit(errorPtr); - Tcl_WCharToUtfDString(nativeDst, -1, errorPtr); + Tcl_WCharToUtfDString(nativeDst, TCL_INDEX_NONE, errorPtr); } return TCL_ERROR; } @@ -1454,7 +1454,7 @@ TraversalDelete( if (errorPtr != NULL) { Tcl_DStringInit(errorPtr); - Tcl_WCharToUtfDString(nativeSrc, -1, errorPtr); + Tcl_WCharToUtfDString(nativeSrc, TCL_INDEX_NONE, errorPtr); } return TCL_ERROR; } @@ -1712,7 +1712,7 @@ ConvertFileNameFormat( */ Tcl_DStringInit(&dsTemp); - Tcl_WCharToUtfDString(nativeName, -1, &dsTemp); + Tcl_WCharToUtfDString(nativeName, TCL_INDEX_NONE, &dsTemp); Tcl_DStringFree(&ds); /* @@ -1952,14 +1952,14 @@ TclpObjListVolumes(void) buf[0] = (char) ('a' + i); if (GetVolumeInformationA(buf, NULL, 0, NULL, NULL, NULL, NULL, 0) || (GetLastError() == ERROR_NOT_READY)) { - elemPtr = Tcl_NewStringObj(buf, -1); + elemPtr = Tcl_NewStringObj(buf, TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); } } } else { for (p = buf; *p != '\0'; p += 4) { p[2] = '/'; - elemPtr = Tcl_NewStringObj(p, -1); + elemPtr = Tcl_NewStringObj(p, TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); } } @@ -2078,7 +2078,7 @@ TclpCreateTemporaryDirectory( */ Tcl_DStringInit(&name); - Tcl_WCharToUtfDString((LPCWSTR) Tcl_DStringValue(&base), -1, &name); + Tcl_WCharToUtfDString((LPCWSTR) Tcl_DStringValue(&base), TCL_INDEX_NONE, &name); Tcl_DStringFree(&base); return TclDStringToObj(&name); } diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 4a07f04..56ef8cb 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -888,7 +888,7 @@ TclpFindExecutable( GetModuleFileNameW(NULL, wName, sizeof(wName)/sizeof(WCHAR)); WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL); TclWinNoBackslash(name); - TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL); + TclSetObjNameOfExecutable(Tcl_NewStringObj(name, TCL_INDEX_NONE), NULL); } /* @@ -1024,7 +1024,7 @@ TclpMatchInDirectory( * pattern. */ - dirName = Tcl_DStringAppend(&dsOrig, pattern, -1); + dirName = Tcl_DStringAppend(&dsOrig, pattern, TCL_INDEX_NONE); } else { dirName = TclDStringAppendLiteral(&dsOrig, "*.*"); } @@ -1103,7 +1103,7 @@ TclpMatchInDirectory( native = data.cFileName; attr = data.dwFileAttributes; Tcl_DStringInit(&ds); - utfname = Tcl_WCharToUtfDString(native, -1, &ds); + utfname = Tcl_WCharToUtfDString(native, TCL_INDEX_NONE, &ds); if (!matchSpecialDots) { /* @@ -1989,7 +1989,7 @@ TclpGetCwd( native += 2; } Tcl_DStringInit(bufferPtr); - Tcl_WCharToUtfDString(native, -1, bufferPtr); + Tcl_WCharToUtfDString(native, TCL_INDEX_NONE, bufferPtr); /* * Convert to forward slashes for easier use in scripts. @@ -2198,7 +2198,7 @@ NativeDev( GetFullPathNameW(nativePath, MAX_PATH, nativeFullPath, &nativePart); Tcl_DStringInit(&ds); - fullPath = Tcl_WCharToUtfDString(nativeFullPath, -1, &ds); + fullPath = Tcl_WCharToUtfDString(nativeFullPath, TCL_INDEX_NONE, &ds); if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) { const char *p; @@ -2501,7 +2501,7 @@ TclpFilesystemPathType( Tcl_DString ds; Tcl_DStringInit(&ds); - Tcl_WCharToUtfDString(volType, -1, &ds); + Tcl_WCharToUtfDString(volType, TCL_INDEX_NONE, &ds); return TclDStringToObj(&ds); } #undef VOL_BUF_SIZE @@ -2649,7 +2649,7 @@ TclpObjNormalizePath( */ nextCheckpoint = 0; - Tcl_AppendToObj(to, currentPathEndPosition, -1); + Tcl_AppendToObj(to, currentPathEndPosition, TCL_INDEX_NONE); /* * Convert link to forward slashes. @@ -2825,7 +2825,7 @@ TclpObjNormalizePath( tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), nextCheckpoint); - Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1); + Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, TCL_INDEX_NONE); path = TclGetStringFromObj(tmpPathPtr, &len); Tcl_SetStringObj(pathPtr, path, len); Tcl_DecrRefCount(tmpPathPtr); @@ -2898,7 +2898,7 @@ TclWinVolumeRelativeNormalize( const char *drive = Tcl_GetString(useThisCwd); absolutePath = Tcl_NewStringObj(drive,2); - Tcl_AppendToObj(absolutePath, path, -1); + Tcl_AppendToObj(absolutePath, path, TCL_INDEX_NONE); Tcl_IncrRefCount(absolutePath); /* @@ -2951,7 +2951,7 @@ TclWinVolumeRelativeNormalize( Tcl_AppendToObj(absolutePath, "/", 1); } Tcl_IncrRefCount(absolutePath); - Tcl_AppendToObj(absolutePath, path+2, -1); + Tcl_AppendToObj(absolutePath, path+2, TCL_INDEX_NONE); } *useThisCwdPtr = useThisCwd; return absolutePath; @@ -2988,7 +2988,7 @@ TclpNativeToNormalized( char *copy, *p; Tcl_DStringInit(&ds); - Tcl_WCharToUtfDString((const WCHAR *) clientData, -1, &ds); + Tcl_WCharToUtfDString((const WCHAR *) clientData, TCL_INDEX_NONE, &ds); copy = Tcl_DStringValue(&ds); len = Tcl_DStringLength(&ds); diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 647b870..fdeb0aa 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -233,7 +233,7 @@ AppendEnvironment( WideCharToMultiByte(CP_UTF8, 0, wBuf, -1, buf, MAX_PATH * 3, NULL, NULL); if (buf[0] != '\0') { - objPtr = Tcl_NewStringObj(buf, -1); + objPtr = Tcl_NewStringObj(buf, TCL_INDEX_NONE); Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); TclWinNoBackslash(buf); @@ -257,7 +257,7 @@ AppendEnvironment( (void) Tcl_JoinPath(pathc, pathv, &ds); objPtr = TclDStringToObj(&ds); } else { - objPtr = Tcl_NewStringObj(buf, -1); + objPtr = Tcl_NewStringObj(buf, TCL_INDEX_NONE); } Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); ckfree(pathv); @@ -517,11 +517,11 @@ TclpSetVariables( if (ptr == NULL) { ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY); if (ptr != NULL) { - Tcl_DStringAppend(&ds, ptr, -1); + Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE); } ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY); if (ptr != NULL) { - Tcl_DStringAppend(&ds, ptr, -1); + Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE); } if (Tcl_DStringLength(&ds) > 0) { Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds), @@ -607,7 +607,7 @@ TclpFindVariable( */ Tcl_DStringInit(&envString); - envUpper = Tcl_WCharToUtfDString(env, -1, &envString); + envUpper = Tcl_WCharToUtfDString(env, TCL_INDEX_NONE, &envString); p1 = strchr(envUpper, '='); if (p1 == NULL) { continue; diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index 1134e12..2106343 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -220,7 +220,7 @@ FindSymbol( Tcl_DStringInit(&ds); TclDStringAppendLiteral(&ds, "_"); - sym2 = Tcl_DStringAppend(&ds, symbol, -1); + sym2 = Tcl_DStringAppend(&ds, symbol, TCL_INDEX_NONE); proc = (void *)GetProcAddress(hInstance, sym2); Tcl_DStringFree(&ds); } diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 29b1c03..4a39e8c 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -679,7 +679,7 @@ TclpCreateTempFile( * Convert the contents from UTF to native encoding */ - native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring); + native = Tcl_UtfToExternalDString(NULL, contents, TCL_INDEX_NONE, &dstring); toCopy = Tcl_DStringLength(&dstring); for (p = native; toCopy > 0; p++, toCopy--) { @@ -1285,12 +1285,12 @@ ApplicationType( applType = APPL_NONE; Tcl_DStringInit(&nameBuf); - Tcl_DStringAppend(&nameBuf, originalName, -1); + Tcl_DStringAppend(&nameBuf, originalName, TCL_INDEX_NONE); nameLen = Tcl_DStringLength(&nameBuf); for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) { Tcl_DStringSetLength(&nameBuf, nameLen); - Tcl_DStringAppend(&nameBuf, extensions[i], -1); + Tcl_DStringAppend(&nameBuf, extensions[i], TCL_INDEX_NONE); Tcl_DStringInit(&ds); nativeName = Tcl_UtfToWCharDString(Tcl_DStringValue(&nameBuf), Tcl_DStringLength(&nameBuf), &ds); @@ -1311,7 +1311,7 @@ ApplicationType( continue; } Tcl_DStringInit(&ds); - strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, -1, &ds)); + strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, TCL_INDEX_NONE, &ds)); Tcl_DStringFree(&ds); ext = strrchr(fullName, '.'); @@ -1403,7 +1403,7 @@ ApplicationType( GetShortPathNameW(nativeFullPath, nativeFullPath, MAX_PATH); Tcl_DStringInit(&ds); - strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, -1, &ds)); + strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, TCL_INDEX_NONE, &ds)); Tcl_DStringFree(&ds); } return applType; @@ -1628,7 +1628,7 @@ BuildCommandLine( * Nothing to escape. */ - Tcl_DStringAppend(&ds, arg, -1); + Tcl_DStringAppend(&ds, arg, TCL_INDEX_NONE); } else { start = arg; for (special = arg; *special != '\0'; ) { diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 403c9d5..f087d70 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1678,7 +1678,7 @@ SerialSetOptionProc( goto getStateFailed; } Tcl_DStringInit(&ds); - native = Tcl_UtfToWCharDString(value, -1, &ds); + native = Tcl_UtfToWCharDString(value, TCL_INDEX_NONE, &ds); result = BuildCommDCBW(native, &dcb); Tcl_DStringFree(&ds); @@ -1779,7 +1779,7 @@ SerialSetOptionProc( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -xchar: should be a list of" - " two elements with each a single 8-bit character", -1)); + " two elements with each a single 8-bit character", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL); } ckfree(argv); @@ -1852,7 +1852,7 @@ SerialSetOptionProc( (DWORD) (flag ? SETDTR : CLRDTR))) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't set DTR signal", -1)); + "can't set DTR signal", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } @@ -1864,7 +1864,7 @@ SerialSetOptionProc( (DWORD) (flag ? SETRTS : CLRRTS))) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't set RTS signal", -1)); + "can't set RTS signal", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } @@ -1876,7 +1876,7 @@ SerialSetOptionProc( (DWORD) (flag ? SETBREAK : CLRBREAK))) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't set BREAK signal", -1)); + "can't set BREAK signal", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 60575df..e806423 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -377,7 +377,7 @@ InitializeHostName( * Convert string from native to UTF then change to lowercase. */ - Tcl_UtfToLower(Tcl_WCharToUtfDString(wbuf, -1, &ds)); + Tcl_UtfToLower(Tcl_WCharToUtfDString(wbuf, TCL_INDEX_NONE, &ds)); } else { if (TclpHasSockets(NULL) == TCL_OK) { @@ -392,7 +392,7 @@ InitializeHostName( Tcl_DStringSetLength(&inDs, 256); if (gethostname(Tcl_DStringValue(&inDs), Tcl_DStringLength(&inDs)) == 0) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), -1, + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), TCL_INDEX_NONE, &ds); } Tcl_DStringFree(&inDs); -- cgit v0.12 From aefbc875acfc5e238b4d17ec233044a07cf23cca Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 19 Jul 2022 08:38:41 +0000 Subject: Update compat/stdlib.h, prevent conflict with modern signature of those functions. --- compat/stdlib.h | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/compat/stdlib.h b/compat/stdlib.h index 6900be3..2f7eaf4 100644 --- a/compat/stdlib.h +++ b/compat/stdlib.h @@ -5,7 +5,7 @@ * This file isn't complete in the ANSI-C sense; it only declares things * that are needed by Tcl. This file is needed even on many systems with * their own stdlib.h (e.g. SunOS) because not all stdlib.h files declare - * all the procedures needed here (such as strtod). + * all the procedures needed here (such as strtol/strtoul). * * Copyright (c) 1991 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. @@ -21,14 +21,18 @@ extern void abort(void); extern double atof(const char *string); extern int atoi(const char *string); extern long atol(const char *string); -extern char * calloc(unsigned int numElements, unsigned int size); +extern void * calloc(unsigned long numElements, unsigned long size); extern void exit(int status); -extern int free(char *blockPtr); +extern void free(void *blockPtr); extern char * getenv(const char *name); -extern char * malloc(unsigned int numBytes); -extern void qsort(void *base, int n, int size, int (*compar)( +extern void * malloc(unsigned long numBytes); +extern void qsort(void *base, unsigned long n, unsigned long size, int (*compar)( const void *element1, const void *element2)); -extern char * realloc(char *ptr, unsigned int numBytes); +extern void * realloc(void *ptr, unsigned long numBytes); +extern char * realpath(const char *path, char *resolved_path); +extern int mkstemps(char *templ, int suffixlen); +extern int mkstemp(char *templ); +extern char * mkdtemp(char *templ); extern long strtol(const char *string, char **endPtr, int base); extern unsigned long strtoul(const char *string, char **endPtr, int base); -- cgit v0.12 From 1fc31a71b82cae8f8431f4bdd1e6f8aa925d65ea Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 19 Jul 2022 12:14:21 +0000 Subject: Undo changes in tclDecls.h from previous commit: Tk still needs it --- generic/tclDecls.h | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 28696df..b869c97 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4069,10 +4069,19 @@ extern const TclStubs *tclStubsPtr; #undef TclUnusedStubEntry #if defined(USE_TCL_STUBS) +# undef Tcl_CreateInterp # undef Tcl_FindExecutable +# undef Tcl_GetStringResult +# undef Tcl_Init # undef Tcl_SetPanicProc # undef Tcl_SetExitProc +# undef Tcl_ObjSetVar2 # undef Tcl_StaticLibrary +# define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) +# define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp)) +# define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp)) +# define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \ + (tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags)) #endif #if defined(_WIN32) && defined(UNICODE) -- cgit v0.12 From 34a90fef7a0a249dffc99dd44cf2f9bcd0e2b45b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 20 Jul 2022 16:25:03 +0000 Subject: Wrong escape in encoding.n --- doc/encoding.n | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/encoding.n b/doc/encoding.n index 2277f9d..c1dbf27 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -117,7 +117,7 @@ which is the Hiragana letter HA. The following example detects the error location in an incomplete UTF-8 sequence: .PP .CS -% set s [\fBencoding convertfrom\fR -failindex i utf-8 "A\xc3"] +% set s [\fBencoding convertfrom\fR -failindex i utf-8 "A\exC3"] A % set i 1 @@ -127,7 +127,7 @@ The following example detects the error location while transforming to ISO8859-1 (ISO-Latin 1): .PP .CS -% set s [\fBencoding convertto\fR -failindex i utf-8 "A\u0141"] +% set s [\fBencoding convertto\fR -failindex i utf-8 "A\eu0141"] A % set i 1 -- cgit v0.12 From 57f0eb9556674426578429b0bfe081f563e1ed63 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 21 Jul 2022 14:03:54 +0000 Subject: More TclGetStringFromObj() usage --- generic/tclBasic.c | 34 +++--- generic/tclBinary.c | 22 ++-- generic/tclEnsemble.c | 332 ++++++++++++++++++++++++-------------------------- generic/tclExecute.c | 31 ++--- generic/tclLink.c | 26 ++-- 5 files changed, 219 insertions(+), 226 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5f32e7d..a0c5a91 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1350,11 +1350,11 @@ TclRegisterCommandTypeName( int isNew; hPtr = Tcl_CreateHashEntry(&commandTypeTable, - (void *) implementationProc, &isNew); + implementationProc, &isNew); Tcl_SetHashValue(hPtr, (void *) nameStr); } else { hPtr = Tcl_FindHashEntry(&commandTypeTable, - (void *) implementationProc); + implementationProc); if (hPtr != NULL) { Tcl_DeleteHashEntry(hPtr); } @@ -1865,7 +1865,7 @@ DeleteInterpProc( */ Tcl_MutexLock(&cancelLock); - hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr); + hPtr = Tcl_FindHashEntry(&cancelTable, iPtr); if (hPtr != NULL) { CancelInfo *cancelInfo = (CancelInfo *)Tcl_GetHashValue(hPtr); @@ -4584,7 +4584,7 @@ Tcl_CancelEval( goto done; } - hPtr = Tcl_FindHashEntry(&cancelTable, (char *) interp); + hPtr = Tcl_FindHashEntry(&cancelTable, interp); if (hPtr == NULL) { /* * No CancelInfo record for this interpreter. @@ -5274,8 +5274,8 @@ TEOV_RunEnterTraces( { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; - int length, traceCode = TCL_OK; + int length, newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + int traceCode = TCL_OK; const char *command = TclGetStringFromObj(commandPtr, &length); /* @@ -5545,7 +5545,7 @@ TclEvalEx( * TCL_EVAL_GLOBAL was set. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); int gotParse = 0; - unsigned int i, objectsUsed = 0; + TCL_HASH_TYPE i, objectsUsed = 0; /* These variables keep track of how much * state has been allocated while evaluating * the script, so that it can be freed @@ -5717,7 +5717,7 @@ TclEvalEx( wordStart = tokenPtr->start; lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL) - ? wordLine : TCL_INDEX_NONE; + ? wordLine : -1; if (eeFramePtr->type == TCL_LOCATION_SOURCE) { iPtr->evalFlags |= TCL_EVAL_FILE; @@ -6150,7 +6150,7 @@ TclArgumentRelease( for (i = 1; i < objc; i++) { CFWord *cfwPtr; Tcl_HashEntry *hPtr = - Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) objv[i]); + Tcl_FindHashEntry(iPtr->lineLAPtr, objv[i]); if (!hPtr) { continue; @@ -6202,7 +6202,7 @@ TclArgumentBCEnter( CFWordBC *lastPtr = NULL; Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hePtr = - Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); + Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); if (!hePtr) { return; @@ -6308,7 +6308,7 @@ TclArgumentBCRelease( while (cfwPtr) { CFWordBC *nextPtr = cfwPtr->nextPtr; Tcl_HashEntry *hPtr = - Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj); + Tcl_FindHashEntry(iPtr->lineLABCPtr, cfwPtr->obj); CFWordBC *xPtr = (CFWordBC *)Tcl_GetHashValue(hPtr); if (xPtr != cfwPtr) { @@ -6373,7 +6373,7 @@ TclArgumentGet( * stack. That is nearest. */ - hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj); + hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, obj); if (hPtr) { CFWord *cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr); @@ -6387,7 +6387,7 @@ TclArgumentGet( * that stack. */ - hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) obj); + hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, obj); if (hPtr) { CFWordBC *cfwPtr = (CFWordBC *)Tcl_GetHashValue(hPtr); @@ -6430,7 +6430,7 @@ Tcl_Eval( * previous call to Tcl_CreateInterp). */ const char *script) /* Pointer to TCL command to execute. */ { - int code = Tcl_EvalEx(interp, script, -1, 0); + int code = Tcl_EvalEx(interp, script, TCL_INDEX_NONE, 0); /* * For backwards compatibility with old C code that predates the object @@ -7279,10 +7279,11 @@ Tcl_AppendObjToErrorInfo( * pertains. */ Tcl_Obj *objPtr) /* Message to record. */ { - const char *message = TclGetString(objPtr); + int length; + const char *message = TclGetStringFromObj(objPtr, &length); Tcl_IncrRefCount(objPtr); - Tcl_AddObjErrorInfo(interp, message, objPtr->length); + Tcl_AddObjErrorInfo(interp, message, length); Tcl_DecrRefCount(objPtr); } @@ -7454,6 +7455,7 @@ Tcl_VarEvalVA( * *---------------------------------------------------------------------- */ + int Tcl_VarEval( Tcl_Interp *interp, diff --git a/generic/tclBinary.c b/generic/tclBinary.c index bf40924..8b974c1 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -649,7 +649,7 @@ SetByteArrayFromAny( TCL_UNUSED(Tcl_Interp *), Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { - size_t length, bad; + int length, bad; const char *src, *srcEnd; unsigned char *dst; Tcl_UniChar ch = 0; @@ -663,8 +663,8 @@ SetByteArrayFromAny( return TCL_OK; } - src = TclGetString(objPtr); - length = bad = objPtr->length; + src = TclGetStringFromObj(objPtr, &length); + bad = length; srcEnd = src + length; /* Note the allocation is over-sized, possibly by a factor of four, @@ -1001,7 +1001,7 @@ TclInitBinaryCmd( static int BinaryFormatCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1506,7 +1506,7 @@ BinaryFormatCmd( static int BinaryScanCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2583,7 +2583,7 @@ DeleteScanNumberCache( static int BinaryEncodeHex( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2627,7 +2627,7 @@ BinaryEncodeHex( static int BinaryDecodeHex( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2751,7 +2751,7 @@ BinaryDecodeHex( static int BinaryEncode64( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2873,7 +2873,7 @@ BinaryEncode64( static int BinaryEncodeUu( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -3022,7 +3022,7 @@ BinaryEncodeUu( static int BinaryDecodeUu( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -3195,7 +3195,7 @@ BinaryDecodeUu( static int BinaryDecode64( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 5c30a0b..7a295ba 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -21,12 +21,12 @@ static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr); static inline int EnsembleUnknownCallback(Tcl_Interp *interp, EnsembleConfig *ensemblePtr, int objc, Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); -static int NsEnsembleImplementationCmdNR(ClientData clientData, +static int NsEnsembleImplementationCmdNR(void *clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); static int NsEnsembleStringOrder(const void *strPtr1, const void *strPtr2); -static void DeleteEnsembleConfig(ClientData clientData); +static void DeleteEnsembleConfig(void *clientData); static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, EnsembleConfig *ensemblePtr, Tcl_HashEntry *hPtr, Tcl_Obj *fix); @@ -70,8 +70,8 @@ enum EnsConfigOpts { }; /* - * This structure defines a Tcl object type that contains a reference to an - * ensemble subcommand (e.g. the "length" in [string length ab]). It is used + * ensembleCmdType is a Tcl object type that contains a reference to an + * ensemble subcommand, e.g. the "length" in [string length ab]. It is used * to cache the mapping between the subcommand itself and the real command * that implements it. */ @@ -151,7 +151,7 @@ NewNsObj( int TclNamespaceEnsembleCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -163,7 +163,8 @@ TclNamespaceEnsembleCmd( Tcl_DictSearch search; Tcl_Obj *listObj; const char *simpleName; - int index, done; + int index; + int done; if (nsPtr == NULL || nsPtr->flags & NS_DEAD) { if (!Tcl_InterpDeleted(interp)) { @@ -187,7 +188,8 @@ TclNamespaceEnsembleCmd( switch ((enum EnsSubcmds) index) { case ENS_CREATE: { const char *name; - int len, allocatedMapFlag = 0; + int len; + int allocatedMapFlag = 0; /* * Defaults */ @@ -498,7 +500,8 @@ TclNamespaceEnsembleCmd( Tcl_SetObjResult(interp, resultObj); } else { - int len, allocatedMapFlag = 0; + int len; + int allocatedMapFlag = 0; Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL, *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */ int permitPrefix, flags = 0; /* silence gcc 4 warning */ @@ -940,7 +943,8 @@ Tcl_SetEnsembleMappingDict( return TCL_ERROR; } if (mapDict != NULL) { - int size, done; + int size; + int done; Tcl_DictSearch search; Tcl_Obj *valuePtr; @@ -1523,7 +1527,8 @@ TclMakeEnsemble( Tcl_DString buf, hiddenBuf; const char **nameParts = NULL; const char *cmdName = NULL; - int i, nameCount = 0, ensembleFlags = 0, hiddenLen; + int i, nameCount = 0; + int ensembleFlags = 0, hiddenLen; /* * Construct the path for the ensemble namespace and create it. @@ -1674,7 +1679,7 @@ TclMakeEnsemble( int TclEnsembleImplementationCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1685,7 +1690,7 @@ TclEnsembleImplementationCmd( static int NsEnsembleImplementationCmdNR( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1704,7 +1709,7 @@ NsEnsembleImplementationCmdNR( int subIdx; /* - * Must recheck objc, since numParameters might have changed. Cf. test + * Must recheck objc since numParameters might have changed. See test * namespace-53.9. */ @@ -1712,7 +1717,7 @@ NsEnsembleImplementationCmdNR( subIdx = 1 + ensemblePtr->numParameters; if (objc < subIdx + 1) { /* - * We don't have a subcommand argument. Make error message. + * No subcommand argument. Make error message. */ Tcl_DString buf; /* Message being built */ @@ -1744,18 +1749,16 @@ NsEnsembleImplementationCmdNR( } /* - * Determine if the table of subcommands is right. If so, we can just look - * up in there and go straight to dispatch. + * If the table of subcommands is valid just lookup up the command there + * and go to dispatch. */ subObj = objv[subIdx]; if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) { /* - * Table of subcommands is still valid; therefore there might be a - * valid cache of discovered information which we can reuse. Do the - * check here, and if we're still valid, we can jump straight to the - * part where we do the invocation of the subcommand. + * Table of subcommands is still valid so if the internal representtion + * is an ensembleCmd, just call it. */ EnsembleCmdRep *ensembleCmd; @@ -1777,8 +1780,8 @@ NsEnsembleImplementationCmdNR( } /* - * Look in the hashtable for the subcommand name; this is the fastest way - * of all if there is no cache in operation. + * Look in the hashtable for the named subcommand. This is the fastest + * path if there is no cache in operation. */ hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, @@ -1786,26 +1789,25 @@ NsEnsembleImplementationCmdNR( if (hPtr != NULL) { /* - * Cache for later in the subcommand object. + * Cache ensemble in the subcommand object for later. */ MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL); } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) { /* - * Could not map, no prefixing, go to unknown/error handling. + * Could not map. No prefixing. Go to unknown/error handling. */ goto unknownOrAmbiguousSubcommand; } else { /* - * If we've not already confirmed the command with the hash as part of - * building our export table, we need to scan the sorted array for - * matches. + * If the command isn't yet confirmed with the hash as part of building + * the export table, scan the sorted array for matches. */ - const char *subcmdName; /* Name of the subcommand, or unique prefix of - * it (will be an error for a non-unique - * prefix). */ + const char *subcmdName; /* Name of the subcommand or unique prefix of + * it (a non-unique prefix produces an error). + */ char *fullName = NULL; /* Full name of the subcommand. */ int stringLength, i; int tableLength = ensemblePtr->subcommandTable.numEntries; @@ -1820,10 +1822,10 @@ NsEnsembleImplementationCmdNR( if (cmp == 0) { if (fullName != NULL) { /* - * Since there's never the exact-match case to worry about - * (hash search filters this), getting here indicates that - * our subcommand is an ambiguous prefix of (at least) two - * exported subcommands, which is an error case. + * Hash search filters out the exact-match case, so getting + * here indicates that the subcommand is an ambiguous + * prefix of at least two exported subcommands, which is an + * error case. */ goto unknownOrAmbiguousSubcommand; @@ -1831,9 +1833,8 @@ NsEnsembleImplementationCmdNR( fullName = ensemblePtr->subcommandArrayPtr[i]; } else if (cmp < 0) { /* - * Because we are searching a sorted table, we can now stop - * searching because we have gone past anything that could - * possibly match. + * The table is sorted so stop searching because a match would + * have been found already. */ break; @@ -1841,7 +1842,7 @@ NsEnsembleImplementationCmdNR( } if (fullName == NULL) { /* - * The subcommand is not a prefix of anything, so bail out! + * The subcommand is not a prefix of anything. Bail out! */ goto unknownOrAmbiguousSubcommand; @@ -1871,21 +1872,19 @@ NsEnsembleImplementationCmdNR( runResultingSubcommand: /* - * Do the real work of execution of the subcommand by building an array of - * objects (note that this is potentially not the same length as the - * number of arguments to this ensemble command), populating it and then - * feeding it back through the main command-lookup engine. In theory, we - * could look up the command in the namespace ourselves, as we already - * have the namespace in which it is guaranteed to exist, + * Execute the subcommand by populating an array of objects, which might + * not be the same length as the number of arguments to this ensemble + * command, and then handing it to the main command-lookup engine. In + * theory, the command could be looked up right here using the namespace in + * which it is guaranteed to exist, * * ((Q: That's not true if the -map option is used, is it?)) * - * but we don't do that (the cacheing of the command object used should - * help with that.) + * but don't do that because cacheing of the command object should help. */ { - Tcl_Obj *copyPtr; /* The actual list of words to dispatch to. + Tcl_Obj *copyPtr; /* The list of words to dispatch on. * Will be freed by the dispatch engine. */ Tcl_Obj **copyObjv; int copyObjc, prefixObjc; @@ -1908,8 +1907,8 @@ NsEnsembleImplementationCmdNR( TclDecrRefCount(prefixObj); /* - * Record what arguments the script sent in so that things like - * Tcl_WrongNumArgs can give the correct error message. Parameters + * Record the words of the command as given so that routines like + * Tcl_WrongNumArgs can produce the correct error message. Parameters * count both as inserted and removed arguments. */ @@ -1931,10 +1930,9 @@ NsEnsembleImplementationCmdNR( unknownOrAmbiguousSubcommand: /* - * Have not been able to match the subcommand asked for with a real - * subcommand that we export. See whether a handler has been registered - * for dealing with this situation. Will only call (at most) once for any - * particular ensemble invocation. + * The named subcommand did not match any exported command. If there is a + * handler registered unknown subcommands, call it, but not more than once + * for this call. */ if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) { @@ -1950,10 +1948,10 @@ NsEnsembleImplementationCmdNR( } /* - * We cannot determine what subcommand to hand off to, so generate a - * (standard) failure message. Note the one odd case compared with - * standard ensemble-like command, which is where a namespace has no - * exported commands at all... + * Could not find a routine for the named subcommand so generate a standard + * failure message. The one odd case compared with a standard + * ensemble-like command is where a namespace has no exported commands at + * all... */ Tcl_ResetResult(interp); @@ -1987,7 +1985,7 @@ NsEnsembleImplementationCmdNR( int TclClearRootEnsemble( - TCL_UNUSED(ClientData *), + TCL_UNUSED(void **), Tcl_Interp *interp, int result) { @@ -2000,8 +1998,8 @@ TclClearRootEnsemble( * * TclInitRewriteEnsemble -- * - * Applies a rewrite of arguments so that an ensemble subcommand will - * report error messages correctly for the overall command. + * Applies a rewrite of arguments so that an ensemble subcommand + * correctly reports any error messages for the overall command. * * Results: * Whether this is the first rewrite applied, a value which must be @@ -2079,7 +2077,7 @@ TclResetRewriteEnsemble( * * TclSpellFix -- * - * Record a spelling correction that needs making in the generation of + * Records a spelling correction that needs making in the generation of * the WrongNumArgs usage message. * * Results: @@ -2093,7 +2091,7 @@ TclResetRewriteEnsemble( static int FreeER( - ClientData data[], + void *data[], TCL_UNUSED(Tcl_Interp *), int result) { @@ -2144,8 +2142,8 @@ TclSpellFix( if (badIdx < iPtr->ensembleRewrite.numInsertedObjs) { /* - * Misspelled value was inserted. We cannot directly jump to the bad - * value, but have to search. + * Misspelled value was inserted. Cannot directly jump to the bad + * value. Must search. */ idx = 1; @@ -2257,22 +2255,22 @@ TclFetchEnsembleRoot( /* * ---------------------------------------------------------------------- * - * EnsmebleUnknownCallback -- + * EnsembleUnknownCallback -- * - * Helper for the ensemble engine that handles the procesing of unknown - * callbacks. See the user documentation of the ensemble unknown handler - * for details; this function is only ever called when such a function is - * defined, and is only ever called once per ensemble dispatch (i.e. if a - * reparse still fails, this isn't called again). + * Helper for the ensemble engine. Calls the routine registered for + * "ensemble unknown" case. See the user documentation of the + * ensemble unknown handler for details. Only called when such a + * function is defined, and is only called once per ensemble dispatch. + * I.e. even if a reparse still fails, this isn't called again. * * Results: * TCL_OK - *prefixObjPtr contains the command words to dispatch * to. - * TCL_CONTINUE - Need to reparse (*prefixObjPtr is invalid). - * TCL_ERROR - Something went wrong! Error message in interpreter. + * TCL_CONTINUE - Need to reparse, i.e. *prefixObjPtr is invalid + * TCL_ERROR - Something went wrong. Error message in interpreter. * * Side effects: - * Calls the Tcl interpreter, so arbitrary. + * Arbitrary, due to evaluation of script provided by client. * * ---------------------------------------------------------------------- */ @@ -2285,28 +2283,28 @@ EnsembleUnknownCallback( Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr) { - int paramc, i, result, prefixObjc; + int paramc, i, prefixObjc; + int result; Tcl_Obj **paramv, *unknownCmd, *ensObj; /* - * Create the unknown command callback to determine what to do. + * Create the "unknown" command callback to determine what to do. */ unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler); TclNewObj(ensObj); Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj); Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj); - for (i=1 ; i reparse. + * Empty result => reparse. */ TclDecrRefCount(*prefixObjPtr); @@ -2361,7 +2354,7 @@ EnsembleUnknownCallback( } /* - * Oh no! An exceptional result. Convert to an error. + * Convert exceptional result to an error. */ if (!Tcl_InterpDeleted(interp)) { @@ -2401,16 +2394,16 @@ EnsembleUnknownCallback( * * MakeCachedEnsembleCommand -- * - * Cache what we've computed so far; it's not nice to repeatedly copy - * strings about. Note that to do this, we start by deleting any old - * representation that there was (though if it was an out of date - * ensemble rep, we can skip some of the deallocation process.) + * Caches what has been computed so far to minimize string copying. + * Starts by deleting any existing representation but reusing the existing + * structure if it is an ensembleCmd. * * Results: - * None + * None. * * Side effects: - * Alters the internal representation of the first object parameter. + * Converts the internal representation of the given object to an + * ensembleCmd. * *---------------------------------------------------------------------- */ @@ -2432,8 +2425,7 @@ MakeCachedEnsembleCommand( } } else { /* - * Kill the old internal rep, and replace it with a brand new one of - * our own. + * Replace any old internal representation with a new one. */ ensembleCmd = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep)); @@ -2459,17 +2451,16 @@ MakeCachedEnsembleCommand( * * DeleteEnsembleConfig -- * - * Destroys the data structure used to represent an ensemble. This is - * called when the ensemble's command is deleted (which happens - * automatically if the ensemble's namespace is deleted.) Maintainers - * should note that ensembles should be deleted by deleting their - * commands. + * Destroys the data structure used to represent an ensemble. Called when + * the procedure for the ensemble is deleted, which happens automatically + * if the namespace for the ensemble is deleted. Deleting the procedure + * for an ensemble is the right way to initiate cleanup. * * Results: * None. * * Side effects: - * Memory is (eventually) deallocated. + * Memory is eventually deallocated. * *---------------------------------------------------------------------- */ @@ -2496,15 +2487,12 @@ ClearTable( static void DeleteEnsembleConfig( - ClientData clientData) + void *clientData) { EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData; Namespace *nsPtr = ensemblePtr->nsPtr; - /* - * Unlink from the ensemble chain if it has not been marked as having been - * done already. - */ + /* Unlink from the ensemble chain if it not already marked as unlinked. */ if (ensemblePtr->next != ensemblePtr) { EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles; @@ -2530,7 +2518,7 @@ DeleteEnsembleConfig( ensemblePtr->flags |= ENSEMBLE_DEAD; /* - * Kill the pointer-containing fields. + * Release the fields that contain pointers. */ ClearTable(ensemblePtr); @@ -2548,10 +2536,9 @@ DeleteEnsembleConfig( } /* - * Arrange for the structure to be reclaimed. Note that this is complex - * because we have to make sure that we can react sensibly when an - * ensemble is deleted during the process of initialising the ensemble - * (especially the unknown callback.) + * Arrange for the structure to be reclaimed. This is complex because it is + * necessary to react sensibly when an ensemble is deleted during its + * initialisation, particularly in the case of an unknown callback. */ Tcl_EventuallyFree(ensemblePtr, TCL_DYNAMIC); @@ -2562,11 +2549,11 @@ DeleteEnsembleConfig( * * BuildEnsembleConfig -- * - * Create the internal data structures that describe how an ensemble - * looks, being a hash mapping from the full command name to the Tcl list - * that describes the implementation prefix words, and a sorted array of - * all the full command names to allow for reasonably efficient - * unambiguous prefix handling. + * Creates the internal data structures that describe how an ensemble + * looks. The structures are a hash map from the full command name to the + * Tcl list that describes the implementation prefix words, and a sorted + * array of all the full command names to allow for reasonably efficient + * handling of an unambiguous prefix. * * Results: * None. @@ -2574,7 +2561,7 @@ DeleteEnsembleConfig( * Side effects: * Reallocates and rebuilds the hash table and array stored at the * ensemblePtr argument. For large ensembles or large namespaces, this is - * a potentially expensive operation. + * may be an expensive operation. * *---------------------------------------------------------------------- */ @@ -2583,10 +2570,10 @@ static void BuildEnsembleConfig( EnsembleConfig *ensemblePtr) { - Tcl_HashSearch search; /* Used for scanning the set of commands in - * the namespace that backs up this - * ensemble. */ - int i, j, isNew; + Tcl_HashSearch search; /* Used for scanning the commands in + * the namespace for this ensemble. */ + int i, j; + int isNew; Tcl_HashTable *hash = &ensemblePtr->subcommandTable; Tcl_HashEntry *hPtr; Tcl_Obj *mapDict = ensemblePtr->subcommandDict; @@ -2602,13 +2589,13 @@ BuildEnsembleConfig( /* * There is a list of exactly what subcommands go in the table. - * Must determine the target for each. + * Determine the target for each. */ TclListObjGetElementsM(NULL, subList, &subc, &subv); if (subList == mapDict) { /* - * Strange case where explicit list of subcommands is same value + * Unusual case where explicit list of subcommands is same value * as the dict mapping to targets. */ @@ -2657,10 +2644,10 @@ BuildEnsembleConfig( } /* - * target was not in the dictionary so map onto the namespace. - * Note in this case that we do not guarantee that the command - * is actually there; that is the programmer's responsibility - * (or [::unknown] of course). + * Target was not in the dictionary. Map onto the namespace. + * In this case there is no guarantee that the command + * is actually there. It is the responsibility of the + * programmer (or [::unknown] of course) to provide the procedure. */ cmdObj = Tcl_NewStringObj(name, -1); @@ -2671,9 +2658,9 @@ BuildEnsembleConfig( } } else if (mapDict) { /* - * No subcmd list, but we do have a mapping dictionary so we should - * use the keys of that. Convert the dictionary's contents into the - * form required for the ensemble's internal hashtable. + * No subcmd list, but there is a mapping dictionary, so + * use the keys of that. Convert the contents of the dictionary into the + * form required for the internal hashtable of the ensemble. */ Tcl_DictSearch dictSearch; @@ -2692,18 +2679,15 @@ BuildEnsembleConfig( } } else { /* - * Discover what commands are actually exported by the namespace. - * What we have is an array of patterns and a hash table whose keys - * are the command names exported by the namespace (the contents do - * not matter here.) We must find out what commands are actually - * exported by filtering each command in the namespace against each of - * the patterns in the export list. Note that we use an intermediate - * hash table to make memory management easier, and because that makes - * exact matching far easier too. + * Use the array of patterns and the hash table whose keys are the + * commands exported by the namespace. The corresponding values do not + * matter here. Filter the commands in the namespace against the + * patterns in the export list to find out what commands are actually + * exported. Use an intermediate hash table to make memory management + * easier and to make exact matching much easier. * - * Suggestion for future enhancement: compute the unique prefixes and - * place them in the hash too, which should make for even faster - * matching. + * Suggestion for future enhancement: Compute the unique prefixes and + * place them in the hash too for even faster matching. */ hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search); @@ -2748,22 +2732,22 @@ BuildEnsembleConfig( /* * Create a sorted array of all subcommands in the ensemble; hash tables * are all very well for a quick look for an exact match, but they can't - * determine things like whether a string is a prefix of another (not - * without lots of preparation anyway) and they're no good for when we're - * generating the error message either. + * determine things like whether a string is a prefix of another, at least + * not without a lot of preparation, and they're not useful for generating + * the error message either. * - * We do this by filling an array with the names (we use the hash keys - * directly to save a copy, since any time we change the array we change - * the hash too, and vice versa) and running quicksort over the array. + * Do this by filling an array with the names: Use the hash keys + * directly to save a copy since any time we change the array we change + * the hash too, and vice versa, and run quicksort over the array. */ ensemblePtr->subcommandArrayPtr = (char **)ckalloc(sizeof(char *) * hash->numEntries); /* - * Fill array from both ends as this makes us less likely to end up with - * performance problems in qsort(), which is good. Note that doing this - * makes this code much more opaque, but the naive alternatve: + * Fill the array from both ends as this reduces the likelihood of + * performance problems in qsort(). This makes this code much more opaque, + * but the naive alternatve: * * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ; * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) { @@ -2771,11 +2755,11 @@ BuildEnsembleConfig( * } * * can produce long runs of precisely ordered table entries when the - * commands in the namespace are declared in a sorted fashion (an ordering - * some people like) and the hashing functions (or the command names - * themselves) are fairly unfortunate. By filling from both ends, it - * requires active malice (and probably a debugger) to get qsort() to have - * awful runtime behaviour. + * commands in the namespace are declared in a sorted fashion, which is an + * ordering some people like, and the hashing functions or the command + * names themselves are fairly unfortunate. Filling from both ends means + * that it requires active malice, and probably a debugger, to get qsort() + * to have awful runtime behaviour. */ i = 0; @@ -2801,8 +2785,7 @@ BuildEnsembleConfig( * * NsEnsembleStringOrder -- * - * Helper function to compare two pointers to two strings for use with - * qsort(). + * Helper to for uset with sort() that compares two string pointers. * * Results: * -1 if the first string is smaller, 1 if the second string is smaller, @@ -2930,14 +2913,15 @@ TclCompileEnsemble( Tcl_Obj *replaced, *replacement; Tcl_Command ensemble = (Tcl_Command) cmdPtr; Command *oldCmdPtr = cmdPtr, *newCmdPtr; - int len, result, flags = 0, i, depth = 1, invokeAnyway = 0; + int result, flags = 0, depth = 1, invokeAnyway = 0; int ourResult = TCL_ERROR; - unsigned numBytes; + int i, len; + TCL_HASH_TYPE numBytes; const char *word; TclNewObj(replaced); Tcl_IncrRefCount(replaced); - if (parsePtr->numWords < depth + 1) { + if (parsePtr->numWords <= depth) { goto failed; } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -3197,7 +3181,7 @@ TclCompileEnsemble( * Throw out any line information generated by the failed compile attempt. */ - while (mapPtr->nuloc - 1 > eclIndex) { + while (mapPtr->nuloc > eclIndex + 1) { mapPtr->nuloc--; ckfree(mapPtr->loc[mapPtr->nuloc].line); mapPtr->loc[mapPtr->nuloc].line = NULL; @@ -3264,10 +3248,11 @@ TclAttemptCompileProc( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; - int result, i; + int result; + int i; Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; int savedStackDepth = envPtr->currStackDepth; - unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; + TCL_HASH_TYPE savedCodeNext = envPtr->codeNext - envPtr->codeStart; int savedAuxDataArrayNext = envPtr->auxDataArrayNext; int savedExceptArrayNext = envPtr->exceptArrayNext; #ifdef TCL_COMPILE_DEBUG @@ -3400,7 +3385,8 @@ CompileToInvokedCommand( Tcl_Token *tokPtr; Tcl_Obj *objPtr, **words; const char *bytes; - int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; + int cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; + int i, numWords, length; /* * Push the words of the command. Take care; the command words may be @@ -3411,9 +3397,9 @@ CompileToInvokedCommand( TclListObjGetElementsM(NULL, replacements, &numWords, &words); for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { - if (i > 0 && i < numWords+1) { - bytes = TclGetString(words[i-1]); - PushLiteral(envPtr, bytes, words[i-1]->length); + if (i > 0 && i <= numWords) { + bytes = TclGetStringFromObj(words[i-1], &length); + PushLiteral(envPtr, bytes, length); continue; } @@ -3441,11 +3427,11 @@ CompileToInvokedCommand( TclNewObj(objPtr); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = TclGetString(objPtr); + bytes = TclGetStringFromObj(objPtr, &length); if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { extraLiteralFlags |= LITERAL_UNSHARED; } - cmdLit = TclRegisterLiteral(envPtr, bytes, objPtr->length, extraLiteralFlags); + cmdLit = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags); TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr); TclEmitPush(cmdLit, envPtr); TclDecrRefCount(objPtr); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 923aae3..e292537 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -511,13 +511,13 @@ VarHashCreateVar( #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ ((TclHasInternalRep((objPtr), &tclIntType)) \ ? (*(tPtr) = TCL_NUMBER_INT, \ - *(ptrPtr) = (ClientData) \ + *(ptrPtr) = (void *) \ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ TclHasInternalRep((objPtr), &tclDoubleType) \ ? (((isnan((objPtr)->internalRep.doubleValue)) \ ? (*(tPtr) = TCL_NUMBER_NAN) \ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ - *(ptrPtr) = (ClientData) \ + *(ptrPtr) = (void *) \ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ ? TCL_ERROR : \ @@ -1348,7 +1348,7 @@ int Tcl_ExprObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - Tcl_Obj *objPtr, /* Points to Tcl object containing expression + Tcl_Obj *objPtr, /* Points to Tcl object containing expression * to evaluate. */ Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression * result is stored if no errors occur. */ @@ -1494,10 +1494,11 @@ CompileExprObj( * TIP #280: No invoker (yet) - Expression compilation. */ - const char *string = TclGetString(objPtr); + int length; + const char *string = TclGetStringFromObj(objPtr, &length); - TclInitCompileEnv(interp, &compEnv, string, objPtr->length, NULL, 0); - TclCompileExpr(interp, string, objPtr->length, &compEnv, 0); + TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); + TclCompileExpr(interp, string, length, &compEnv, 0); /* * Successful compilation. If the expression yielded no instructions, @@ -2105,8 +2106,8 @@ TEBCresume( Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr; Tcl_Obj **objv = NULL; - int objc = 0; - int opnd, length, pcAdjustment; + int length, objc = 0; + int opnd, pcAdjustment; Var *varPtr, *arrayPtr; #ifdef TCL_COMPILE_DEBUG char cmdNameBuf[21]; @@ -3184,7 +3185,8 @@ TEBCresume( */ { - int storeFlags, len; + int storeFlags; + int len; case INST_STORE_ARRAY4: opnd = TclGetUInt4AtPtr(pc+1); @@ -4660,7 +4662,7 @@ TEBCresume( TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n", O2S(valuePtr))); - for (i=contextPtr->index ; i>=0 ; i--) { + for (i = contextPtr->index ; i >= 0 ; i--) { miPtr = contextPtr->callPtr->chain + i; if (miPtr->isFilter || miPtr->mPtr->declaringClassPtr != classPtr) { @@ -4829,8 +4831,8 @@ TEBCresume( */ { - int index, numIndices, fromIdx, toIdx; - int nocase, match, length2, cflags, s1len, s2len; + int numIndices, nocase, match, cflags; + int length2, fromIdx, toIdx, index, s1len, s2len; const char *s1, *s2; case INST_LIST: @@ -6866,7 +6868,8 @@ TEBCresume( */ { - int opnd2, allocateDict, done, i, allocdict; + int opnd2, allocateDict, done, allocdict; + int i; Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr; Tcl_Obj *emptyPtr, **keyPtrPtr; Tcl_DictSearch *searchPtr; @@ -10046,7 +10049,7 @@ EvalStatsCmd( #ifdef TCL_MEM_DEBUG Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n"); - TclDumpMemoryInfo((ClientData) objPtr, 1); + TclDumpMemoryInfo(objPtr, 1); #endif Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); diff --git a/generic/tclLink.c b/generic/tclLink.c index 384fcf3..6bd65fa 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -95,7 +95,7 @@ typedef struct Link { * Forward references to functions defined later in this file: */ -static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, +static char * LinkTraceProc(void *clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static Tcl_Obj * ObjValue(Link *linkPtr); static void LinkFree(Link *linkPtr); @@ -527,7 +527,7 @@ GetUWide( Tcl_WideUInt *uwidePtr) { Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr; - ClientData clientData; + void *clientData; int type, intValue; if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) { @@ -633,14 +633,15 @@ SetInvalidRealFromAny( { const char *str; const char *endPtr; + int length; - str = TclGetString(objPtr); - if ((objPtr->length == 1) && (str[0] == '.')) { + str = TclGetStringFromObj(objPtr, &length); + if ((length == 1) && (str[0] == '.')) { objPtr->typePtr = &invalidRealType; objPtr->internalRep.doubleValue = 0.0; return TCL_OK; } - if (TclParseNumber(NULL, objPtr, NULL, str, objPtr->length, &endPtr, + if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr, TCL_PARSE_DECIMAL_ONLY) == TCL_OK) { /* * If number is followed by [eE][+-]?, then it is an invalid @@ -678,13 +679,14 @@ GetInvalidIntFromObj( Tcl_Obj *objPtr, int *intPtr) { - const char *str = TclGetString(objPtr); + int length; + const char *str = TclGetStringFromObj(objPtr, &length); - if ((objPtr->length == 0) || ((objPtr->length == 2) && (str[0] == '0') + if ((length == 0) || ((length == 2) && (str[0] == '0') && strchr("xXbBoOdD", str[1]))) { *intPtr = 0; return TCL_OK; - } else if ((objPtr->length == 1) && strchr("+-", str[0])) { + } else if ((length == 1) && strchr("+-", str[0])) { *intPtr = (str[0] == '+'); return TCL_OK; } @@ -743,7 +745,7 @@ GetInvalidDoubleFromObj( static char * LinkTraceProc( - ClientData clientData, /* Contains information about the link. */ + void *clientData, /* Contains information about the link. */ Tcl_Interp *interp, /* Interpreter containing Tcl variable. */ TCL_UNUSED(const char *) /*name1*/, TCL_UNUSED(const char *) /*name2*/, @@ -896,8 +898,8 @@ LinkTraceProc( switch (linkPtr->type) { case TCL_LINK_STRING: - value = TclGetString(valueObj); - valueLength = valueObj->length + 1; + value = TclGetStringFromObj(valueObj, &valueLength); + valueLength++; /* include end of string char */ pp = (char **) linkPtr->addr; *pp = (char *)ckrealloc(*pp, valueLength); @@ -905,7 +907,7 @@ LinkTraceProc( return NULL; case TCL_LINK_CHARS: - value = (char *) Tcl_GetStringFromObj(valueObj, &valueLength); + value = (char *) TclGetStringFromObj(valueObj, &valueLength); valueLength++; /* include end of string char */ if (valueLength > linkPtr->bytes) { return (char *) "wrong size of char* value"; -- cgit v0.12 -- cgit v0.12 From 7af0d34d1f3f2c97eb05aca168447160d61dfcc8 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 21 Jul 2022 18:55:30 +0000 Subject: added tests illustrating bug [b3977d199b] --- tests/io.test | 89 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 89 insertions(+) diff --git a/tests/io.test b/tests/io.test index fe1052a..866d199 100644 --- a/tests/io.test +++ b/tests/io.test @@ -2984,6 +2984,95 @@ test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotM interp delete y } "" +test io-29.36.1 {gets on translation auto with "\r" in QA communication mode, possible regression, bug [b3977d199b]} -constraints { + socket tempNotMac fileevent +} -setup { + set s [open "|[list [interpreter] << { + proc accept {so args} { + fconfigure $so -translation binary + puts -nonewline $so "who are you?\r"; flush $so + set a [gets $so] + puts -nonewline $so "really $a?\r"; flush $so + set a [gets $so] + close $so + set ::done $a + } + set s [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + puts [lindex [fconfigure $s -sockname] 2] + foreach c {1 2} { + vwait ::done + puts $::done + } + }]" r] + set c {} + set result {} +} -body { + set port [gets $s] + foreach t {{cr lf} auto} { + set c [socket 127.0.0.1 $port] + fconfigure $c -buffering line -translation $t + lappend result $t + while {1} { + set q [gets $c] + switch -- $q { + "who are you?" {puts $c "client"} + "really client?" {puts $c "yes"; lappend result $q; break} + default {puts $c "wrong"; lappend result "unexpected input \"$q\""; break} + } + } + lappend result [gets $s] + close $c; set c {} + } + set result +} -cleanup { + close $s + if {$c ne {}} { close $c } + unset -nocomplain s c port t q +} -result [list {cr lf} "really client?" yes auto "really client?" yes] +test io-29.36.2 {gets on translation auto with "\r\n" in different buffers, bug [b3977d199b]} -constraints { + socket tempNotMac fileevent +} -setup { + set s [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + set c {} +} -body { + set ::cnt 0 + proc accept {so args} { + fconfigure $so -translation binary + puts -nonewline $so "1 line\r" + puts -nonewline $so "\n2 li" + flush $so + # now force separate packets + puts -nonewline $so "ne\r" + flush $so + if {$::cnt & 1} { + vwait ::cli; # simulate short delay (so client can process events, just wait for it) + } else { + # we don't have a delay, so client would get the lines as single chunk + } + puts -nonewline $so "\n3 line" + flush $so + close $so + } + while {$::cnt < 4} { incr ::cnt + set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] + fconfigure $c -blocking 0 -buffering line -translation auto + fileevent $c readable [list apply {c { + if {[gets $c line] >= 0} { + lappend ::cli <$line> + } elseif {[eof $c]} { + set ::done 1 + } + }} $c] + vwait ::done + close $c; set c {} + } + set ::cli +} -cleanup { + close $s + if {$c ne {}} { close $c } + unset -nocomplain ::done ::cli ::cnt s c +} -result [lrepeat 4 {<1 line>} {<2 line>} {<3 line>}] + # Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read. test io-30.1 {Tcl_Write lf, Tcl_Read lf} { -- cgit v0.12 From 951e955d2c89cad1bd96d2e9ec08233d1a14f2f1 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 22 Jul 2022 06:32:40 +0000 Subject: Added testapplylambda to illustrate bug in apply when the passed argument does NOT have Lambda internal representation but the body of the lambda DOES have an internal ByteCode representation. --- generic/tclTest.c | 84 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 83 insertions(+), 1 deletion(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index e3c6663..77540e2 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -342,6 +342,7 @@ static Tcl_ObjCmdProc TestInterpResolverCmd; #if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL) static Tcl_ObjCmdProc TestcpuidCmd; #endif +static Tcl_ObjCmdProc TestApplyLambdaObjCmd; static const Tcl_Filesystem testReportingFilesystem = { "reporting", @@ -715,6 +716,8 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testsetencpath", TestsetencpathObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testapplylambda", TestApplyLambdaObjCmd, + NULL, NULL); if (TclObjTest_Init(interp) != TCL_OK) { return TCL_ERROR; @@ -8120,7 +8123,85 @@ TestInterpResolverCmd( } return TCL_OK; } - + +/* + *------------------------------------------------------------------------ + * + * TestApplyLambdaObjCmd -- + * + * Implements the Tcl command testapplylambda. This tests the apply + * implementation handling of a lambda where the lambda has a list + * internal representation where the second element's internal + * representation is already a byte code object. + * + * Results: + * TCL_OK - Success. Caller should check result is 42 + * TCL_ERROR - Error. + * + * Side effects: + * In the presence of the apply bug, may panic. Otherwise + * Interpreter result holds result or error message. + * + *------------------------------------------------------------------------ + */ +int TestApplyLambdaObjCmd ( + ClientData notUsed, + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *lambdaObjs[2]; + Tcl_Obj *evalObjs[2]; + Tcl_Obj *lambdaObj; + int result; + + /* Create a lambda {{} {set a 42}} */ + lambdaObjs[0] = Tcl_NewObj(); /* No parameters */ + lambdaObjs[1] = Tcl_NewStringObj("set a 42", -1); /* Body */ + lambdaObj = Tcl_NewListObj(2, lambdaObjs); + Tcl_IncrRefCount(lambdaObj); + + /* Create the command "apply {{} {set a 42}" */ + evalObjs[0] = Tcl_NewStringObj("apply", -1); + Tcl_IncrRefCount(evalObjs[0]); + /* + * NOTE: IMPORTANT TO EXHIBIT THE BUG. We duplicate the lambda because + * it will get shimmered to a Lambda internal representation but we + * want to hold on to our list representation. + */ + evalObjs[1] = Tcl_DuplicateObj(lambdaObj); + Tcl_IncrRefCount(evalObjs[1]); + + /* Evaluate it */ + result = Tcl_EvalObjv(interp, 2, evalObjs, TCL_EVAL_GLOBAL); + if (result != TCL_OK) { + Tcl_DecrRefCount(evalObjs[0]); + Tcl_DecrRefCount(evalObjs[1]); + return result; + } + /* + * So far so good. At this point, + * - evalObjs[1] has an internal representation of Lambda + * - lambdaObj[1] ({set a 42}) has been shimmered to + * an internal representation of ByteCode. + */ + Tcl_DecrRefCount(evalObjs[1]); /* Don't need this anymore */ + /* + * The bug trigger. Repeating the command but: + * - we are calling apply with a lambda that is a list (as BEFORE), + * BUT + * - The body of the lambda (lambdaObjs[1]) ALREADY has internal + * representation of ByteCode and thus will not be compiled again + */ + evalObjs[1] = lambdaObj; /* lambdaObj already has a ref count so + no need for IncrRef */ + result = Tcl_EvalObjv(interp, 2, evalObjs, TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(evalObjs[0]); + Tcl_DecrRefCount(lambdaObj); + + return result; +} + /* * Local Variables: * mode: c @@ -8130,3 +8211,4 @@ TestInterpResolverCmd( * indent-tabs-mode: nil * End: */ + -- cgit v0.12 From 5f5c1bf7f1f0c4fb33e50301c87ad228cc1cc366 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 22 Jul 2022 11:10:15 +0000 Subject: Fix and test crash using apply when the passed argument does NOT have already Lambda internal representation but the body of the lambda DOES have an internal ByteCode representation. --- generic/tclProc.c | 8 ++++++++ tests/apply.test | 9 +++++++++ 2 files changed, 17 insertions(+) diff --git a/generic/tclProc.c b/generic/tclProc.c index 17635e7..9677f02 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -2457,6 +2457,14 @@ SetLambdaFromAny( argsPtr = objv[0]; bodyPtr = objv[1]; + /* + * Bugfix for testapplylambda. If we are constructing a new lambda, + * the body must be recompiled even if it is already a ByteCode object. + * Otherwise the procPtr->numCompiledLocals will not get updated causing + * a crash as local variable space is not allocated. + */ + (void) TclGetString(bodyPtr); /* Ensure string representation exists */ + TclFreeInternalRep(bodyPtr); /* * Create and initialize the Proc struct. The cmdPtr field is set to NULL diff --git a/tests/apply.test b/tests/apply.test index e2be172..32dff08 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -22,6 +22,8 @@ if {[info commands ::apply] eq {}} { } testConstraint memory [llength [info commands memory]] +testConstraint applylambda [llength [info commands testapplylambda]] + # Tests for wrong number of arguments @@ -306,6 +308,13 @@ test apply-9.3 {leaking internal rep} -setup { unset -nocomplain end i x tmp leakedBytes } -result 0 +# Tests for specific bugs +test apply-10.1 {Test for precompiled bytecode body} -constraints { + applylambda +} -body { + testapplylambda +} -result 42 + # Tests for the avoidance of recompilation # cleanup -- cgit v0.12 From b69f262ad8aca1cb0d2e9d3a3c906b0eea06bb6c Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 22 Jul 2022 13:10:32 +0000 Subject: amend to [f3db59139e] (fix [713653b951]) - i386 only, resolve mixed declarations and code (forbiddeen in ISO C) --- generic/tclStrToD.c | 45 ++++++++++++++++++++++++--------------------- 1 file changed, 24 insertions(+), 21 deletions(-) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 375746d..557eaa1 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -51,44 +51,43 @@ * file exists only on Linux; it is missing on Cygwin and MinGW. Most gcc-isms * and ix86-isms are factored out here. */ - -#if defined(__GNUC__) +# if defined(__GNUC__) typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__))); -#define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw)) -#define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw)) -# define FPU_IEEE_ROUNDING 0x027F -# define ADJUST_FPU_CONTROL_WORD -#define TCL_IEEE_DOUBLE_ROUNDING \ +# define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw)) +# define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw)) +# define FPU_IEEE_ROUNDING 0x027F +# define ADJUST_FPU_CONTROL_WORD +# define TCL_IEEE_DOUBLE_ROUNDING_DECL \ fpu_control_t roundTo53Bits = FPU_IEEE_ROUNDING; \ - fpu_control_t oldRoundingMode; \ + fpu_control_t oldRoundingMode; +# define TCL_IEEE_DOUBLE_ROUNDING \ _FPU_GETCW(oldRoundingMode); \ _FPU_SETCW(roundTo53Bits) -#define TCL_DEFAULT_DOUBLE_ROUNDING \ +# define TCL_DEFAULT_DOUBLE_ROUNDING \ _FPU_SETCW(oldRoundingMode) /* * Sun ProC needs sunmath for rounding control on x86 like gcc above. */ -#elif defined(__sun) -#include -#define TCL_IEEE_DOUBLE_ROUNDING \ +# elif defined(__sun) +# include +# define TCL_IEEE_DOUBLE_ROUNDING_DECL +# define TCL_IEEE_DOUBLE_ROUNDING \ ieee_flags("set","precision","double",NULL) -#define TCL_DEFAULT_DOUBLE_ROUNDING \ +# define TCL_DEFAULT_DOUBLE_ROUNDING \ ieee_flags("clear","precision",NULL,NULL) +# endif +#endif /* * Other platforms are assumed to always operate in full IEEE mode, so we make * the macros to go in and out of that mode do nothing. */ - -#else /* !__GNUC__ && !__sun */ -#define TCL_IEEE_DOUBLE_ROUNDING ((void) 0) -#define TCL_DEFAULT_DOUBLE_ROUNDING ((void) 0) -#endif -#else /* !__i386 */ -#define TCL_IEEE_DOUBLE_ROUNDING ((void) 0) -#define TCL_DEFAULT_DOUBLE_ROUNDING ((void) 0) +#ifndef TCL_IEEE_DOUBLE_ROUNDING /* !__i386 || (!__GNUC__ && !__sun) */ +# define TCL_IEEE_DOUBLE_ROUNDING_DECL +# define TCL_IEEE_DOUBLE_ROUNDING ((void) 0) +# define TCL_DEFAULT_DOUBLE_ROUNDING ((void) 0) #endif /* @@ -1627,6 +1626,8 @@ MakeLowPrecisionDouble( int numSigDigs, /* Number of digits in the significand */ long exponent) /* Power of ten */ { + TCL_IEEE_DOUBLE_ROUNDING_DECL + mp_int significandBig; /* Significand expressed as a bignum. */ /* @@ -1750,6 +1751,8 @@ MakeHighPrecisionDouble( int numSigDigs, /* Number of significant digits */ long exponent) /* Power of 10 by which to multiply */ { + TCL_IEEE_DOUBLE_ROUNDING_DECL + int machexp; /* Machine exponent of a power of 10. */ /* -- cgit v0.12 From c3cc26df50b8e700e15a735e75defe3b0e7c1275 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 22 Jul 2022 16:22:22 +0000 Subject: fixes logical error in test io-29.36.1 (translation {auto} causes that answer "client" reaches the server-side as "client\r\n", and `gets` by translation {binary} behaves nearly identical to {lf} mode, so sends "really client\r?\r" in the next question), switching to {auto lf} now --- tests/io.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/io.test b/tests/io.test index f75f111..8df28ba 100644 --- a/tests/io.test +++ b/tests/io.test @@ -3013,7 +3013,7 @@ test io-29.36.1 {gets on translation auto with "\r" in QA communication mode, po set result {} } -body { set port [gets $s] - foreach t {{cr lf} auto} { + foreach t {{cr lf} {auto lf}} { set c [socket 127.0.0.1 $port] fconfigure $c -buffering line -translation $t lappend result $t @@ -3033,7 +3033,7 @@ test io-29.36.1 {gets on translation auto with "\r" in QA communication mode, po close $s if {$c ne {}} { close $c } unset -nocomplain s c port t q -} -result [list {cr lf} "really client?" yes auto "really client?" yes] +} -result [list {cr lf} "really client?" yes {auto lf} "really client?" yes] test io-29.36.2 {gets on translation auto with "\r\n" in different buffers, bug [b3977d199b]} -constraints { socket tempNotMac fileevent } -setup { -- cgit v0.12 From 49f09ae8c228ad19029f35a4f40ba6dc6c5d5fff Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 22 Jul 2022 17:36:57 +0000 Subject: extends test io-29.36.2 for better illustration when we'll get extra NL - if no "\r" in last buffer, so only EOF causes exit from gets (flag INPUT_SAW_CR gets reset incorrectly) --- tests/io.test | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/tests/io.test b/tests/io.test index 8df28ba..3b374c1 100644 --- a/tests/io.test +++ b/tests/io.test @@ -3054,11 +3054,15 @@ test io-29.36.2 {gets on translation auto with "\r\n" in different buffers, bug } else { # we don't have a delay, so client would get the lines as single chunk } + # we'll try with "\r" and without "\r" (to cover both branches, where "\r" and "eof" causes exit from [gets] by 3rd line) puts -nonewline $so "\n3 line" + if {!($::cnt % 3)} { + puts -nonewline $so "\r" + } flush $so close $so } - while {$::cnt < 4} { incr ::cnt + while {$::cnt < 6} { incr ::cnt set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] fconfigure $c -blocking 0 -buffering line -translation auto fileevent $c readable [list apply {c { @@ -3076,7 +3080,7 @@ test io-29.36.2 {gets on translation auto with "\r\n" in different buffers, bug close $s if {$c ne {}} { close $c } unset -nocomplain ::done ::cli ::cnt s c -} -result [lrepeat 4 {<1 line>} {<2 line>} {<3 line>}] +} -result [lrepeat 6 {<1 line>} {<2 line>} {<3 line>}] # Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read. -- cgit v0.12 From 255250308e8dba52bc7e154ed96e6b15859b064f Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 22 Jul 2022 17:41:48 +0000 Subject: fixes [b3977d199b] - don't reset INPUT_SAW_CR unless the buffer get really translated (missing "\r" caused that flag got reset too early, because the translation takes place at next round by EOF) --- generic/tclIO.c | 390 +++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 260 insertions(+), 130 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 108114c..e102675 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -340,7 +340,8 @@ static const Tcl_ObjType chanObjType = { (((st)->csPtrW) && ((fl) & TCL_WRITABLE))) #define MAX_CHANNEL_BUFFER_SIZE (1024*1024) - + + /* *--------------------------------------------------------------------------- * @@ -510,7 +511,8 @@ ChanWrite( return chanPtr->typePtr->outputProc(chanPtr->instanceData, src, srcLen, errnoPtr); } - + + /* *--------------------------------------------------------------------------- * @@ -538,7 +540,8 @@ TclInitIOSubsystem(void) (void) TCL_TSD_INIT(&dataKey); } - + + /* *------------------------------------------------------------------------- * @@ -684,7 +687,8 @@ TclFinalizeIOSubsystem(void) TclpFinalizeSockets(); TclpFinalizePipes(); } - + + /* *---------------------------------------------------------------------- * @@ -725,7 +729,8 @@ Tcl_SetStdChannel( break; } } - + + /* *---------------------------------------------------------------------- * @@ -801,7 +806,8 @@ Tcl_GetStdChannel( } return channel; } - + + /* *---------------------------------------------------------------------- * @@ -839,7 +845,8 @@ Tcl_CreateCloseHandler( cbPtr->nextPtr = statePtr->closeCbPtr; statePtr->closeCbPtr = cbPtr; } - + + /* *---------------------------------------------------------------------- * @@ -884,7 +891,8 @@ Tcl_DeleteCloseHandler( cbPrevPtr = cbPtr; } } - + + /* *---------------------------------------------------------------------- * @@ -940,7 +948,8 @@ GetChannelTable( } return hTblPtr; } - + + /* *---------------------------------------------------------------------- * @@ -1030,7 +1039,8 @@ DeleteChannelTable( Tcl_DeleteHashTable(hTblPtr); ckfree(hTblPtr); } - + + /* *---------------------------------------------------------------------- * @@ -1086,7 +1096,8 @@ CheckForStdChannelsBeingClosed( } } } - + + /* *---------------------------------------------------------------------- * @@ -1119,7 +1130,8 @@ Tcl_IsStandardChannel( return 0; } } - + + /* *---------------------------------------------------------------------- * @@ -1176,7 +1188,8 @@ Tcl_RegisterChannel( } statePtr->refCount++; } - + + /* *---------------------------------------------------------------------- * @@ -1261,7 +1274,8 @@ Tcl_UnregisterChannel( } return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -1307,7 +1321,8 @@ Tcl_DetachChannel( return DetachChannel(interp, chan); } - + + /* *---------------------------------------------------------------------- * @@ -1380,7 +1395,8 @@ DetachChannel( return TCL_OK; } - + + /* *--------------------------------------------------------------------------- * @@ -1462,7 +1478,8 @@ Tcl_GetChannel( return (Tcl_Channel) chanPtr; } - + + /* *--------------------------------------------------------------------------- * @@ -1558,7 +1575,8 @@ TclGetChannelFromObj( return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -1766,7 +1784,8 @@ Tcl_CreateChannel( } return (Tcl_Channel) chanPtr; } - + + /* *---------------------------------------------------------------------- * @@ -1995,7 +2014,8 @@ ChannelFree( } chanPtr->typePtr = NULL; } - + + /* *---------------------------------------------------------------------- * @@ -2183,7 +2203,8 @@ Tcl_UnstackChannel( return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -2211,7 +2232,8 @@ Tcl_GetStackedChannel( return (Tcl_Channel) chanPtr->downChanPtr; } - + + /* *---------------------------------------------------------------------- * @@ -2239,7 +2261,8 @@ Tcl_GetTopChannel( return (Tcl_Channel) chanPtr->state->topChanPtr; } - + + /* *---------------------------------------------------------------------- * @@ -2265,7 +2288,8 @@ Tcl_GetChannelInstanceData( return chanPtr->instanceData; } - + + /* *---------------------------------------------------------------------- * @@ -2292,7 +2316,8 @@ Tcl_GetChannelThread( return chanPtr->state->managingThread; } - + + /* *---------------------------------------------------------------------- * @@ -2318,7 +2343,8 @@ Tcl_GetChannelType( return chanPtr->typePtr; } - + + /* *---------------------------------------------------------------------- * @@ -2346,7 +2372,8 @@ Tcl_GetChannelMode( return (statePtr->flags & (TCL_READABLE | TCL_WRITABLE)); } - + + /* *---------------------------------------------------------------------- * @@ -2373,7 +2400,8 @@ Tcl_GetChannelName( return statePtr->channelName; } - + + /* *---------------------------------------------------------------------- * @@ -2415,7 +2443,8 @@ Tcl_GetChannelHandle( } return result; } - + + /* *--------------------------------------------------------------------------- * @@ -2483,7 +2512,8 @@ IsShared( { return bufPtr->refCount > 1; } - + + /* *---------------------------------------------------------------------- * @@ -2572,7 +2602,8 @@ RecycleBuffer( bufPtr->nextAdded = BUFFER_PADDING; bufPtr->nextPtr = NULL; } - + + /* *---------------------------------------------------------------------- * @@ -2608,7 +2639,8 @@ DiscardOutputQueued( RecycleBuffer(statePtr, bufPtr, 0); } } - + + /* *---------------------------------------------------------------------- * @@ -2642,7 +2674,8 @@ CheckForDeadChannel( } return 1; } - + + /* *---------------------------------------------------------------------- * @@ -2944,7 +2977,8 @@ FlushChannel( TclChannelRelease((Tcl_Channel)chanPtr); return errorCode; } - + + /* *---------------------------------------------------------------------- * @@ -3125,7 +3159,8 @@ CloseChannel( return errorCode; } - + + /* *---------------------------------------------------------------------- * @@ -3240,7 +3275,8 @@ Tcl_CutChannel( /* Channel is not managed by any thread */ statePtr->managingThread = NULL; } - + + /* *---------------------------------------------------------------------- * @@ -3330,7 +3366,8 @@ Tcl_SpliceChannel( ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_INSERT); } } - + + /* *---------------------------------------------------------------------- * @@ -3524,7 +3561,8 @@ Tcl_Close( } return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -3658,7 +3696,8 @@ Tcl_CloseEx( return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -3734,7 +3773,8 @@ CloseWrite( return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -3870,7 +3910,8 @@ CloseChannelPart( ResetFlag(statePtr, flags & (TCL_READABLE | TCL_WRITABLE)); return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -3964,7 +4005,8 @@ Tcl_ClearChannelHandlers( } statePtr->scriptRecordPtr = NULL; } - + + /* *---------------------------------------------------------------------- * @@ -4018,7 +4060,8 @@ Tcl_Write( } return srcLen; } - + + /* *---------------------------------------------------------------------- * @@ -4075,7 +4118,8 @@ Tcl_WriteRaw( return written; } - + + /* *--------------------------------------------------------------------------- * @@ -4142,7 +4186,8 @@ Tcl_WriteChars( TclDecrRefCount(objPtr); return result; } - + + /* *--------------------------------------------------------------------------- * @@ -4196,7 +4241,8 @@ Tcl_WriteObj( return WriteChars(chanPtr, src, srcLen); } } - + + static void WillWrite( Channel *chanPtr) @@ -4211,7 +4257,8 @@ WillWrite( ChanSeek(chanPtr, -inputBuffered, SEEK_CUR, &ignore); } } - + + static int WillRead( Channel *chanPtr) @@ -4244,7 +4291,8 @@ WillRead( } return 0; } - + + /* *---------------------------------------------------------------------- * @@ -4444,7 +4492,8 @@ Write( return total; } - + + /* *--------------------------------------------------------------------------- * @@ -4483,7 +4532,8 @@ Tcl_Gets( TclDecrRefCount(objPtr); return charsStored; } - + + /* *--------------------------------------------------------------------------- * @@ -4694,7 +4744,6 @@ Tcl_GetsObj( eol = dst; skip = 1; if (GotFlag(statePtr, INPUT_SAW_CR)) { - ResetFlag(statePtr, INPUT_SAW_CR); if ((eol < dstEnd) && (*eol == '\n')) { /* * Skip the raw bytes that make up the '\n'. @@ -4744,8 +4793,10 @@ Tcl_GetsObj( skip++; } eol--; + ResetFlag(statePtr, INPUT_SAW_CR); goto gotEOL; } else if (*eol == '\n') { + ResetFlag(statePtr, INPUT_SAW_CR); goto gotEOL; } } @@ -4895,7 +4946,8 @@ Tcl_GetsObj( TclChannelRelease((Tcl_Channel)chanPtr); return copiedTotal; } - + + /* *--------------------------------------------------------------------------- * @@ -5169,7 +5221,8 @@ TclGetsObjBinary( TclChannelRelease((Tcl_Channel)chanPtr); return copiedTotal; } - + + /* *--------------------------------------------------------------------------- * @@ -5211,7 +5264,8 @@ GetBinaryEncoding() } return tsdPtr->binaryEncoding; } - + + /* *--------------------------------------------------------------------------- * @@ -5404,7 +5458,8 @@ FilterInputBytes( gsPtr->bufPtr = bufPtr; return 0; } - + + /* *--------------------------------------------------------------------------- * @@ -5489,7 +5544,8 @@ PeekAhead( gsPtr->bytesWrote = 0; gsPtr->charsWrote = 0; } - + + /* *--------------------------------------------------------------------------- * @@ -5552,7 +5608,8 @@ CommonGetsCleanup( } } } - + + /* *---------------------------------------------------------------------- * @@ -5597,7 +5654,8 @@ Tcl_Read( return DoRead(chanPtr, dst, bytesToRead, 0); } - + + /* *---------------------------------------------------------------------- * @@ -5715,7 +5773,8 @@ Tcl_ReadRaw( } return copied; } - + + /* *--------------------------------------------------------------------------- * @@ -5970,7 +6029,8 @@ DoReadChars( TclChannelRelease((Tcl_Channel)chanPtr); return copied; } - + + /* *--------------------------------------------------------------------------- * @@ -6019,7 +6079,8 @@ ReadBytes( bufPtr->nextRemoved += toRead; return toRead; } - + + /* *--------------------------------------------------------------------------- * @@ -6422,7 +6483,8 @@ ReadChars( return numChars; } } - + + /* *--------------------------------------------------------------------------- * @@ -6598,7 +6660,8 @@ TranslateInputEOL( ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); } } - + + /* *---------------------------------------------------------------------- * @@ -6686,7 +6749,8 @@ Tcl_Ungets( UpdateInterest(chanPtr); return len; } - + + /* *---------------------------------------------------------------------- * @@ -6730,7 +6794,8 @@ Tcl_Flush( return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -6777,7 +6842,8 @@ DiscardInputQueued( statePtr->saveInBufPtr = NULL; } } - + + /* *--------------------------------------------------------------------------- * @@ -6926,7 +6992,8 @@ GetInput( ReleaseChannelBuffer(bufPtr); return result; } - + + /* *---------------------------------------------------------------------- * @@ -7094,7 +7161,8 @@ Tcl_Seek( return curPos; } - + + /* *---------------------------------------------------------------------- * @@ -7183,7 +7251,8 @@ Tcl_Tell( } return curPos + outputBuffered; } - + + /* *--------------------------------------------------------------------------- * @@ -7224,7 +7293,8 @@ Tcl_TellOld( return (int) Tcl_WideAsLong(wResult); } - + + /* *--------------------------------------------------------------------------- * @@ -7296,7 +7366,8 @@ Tcl_TruncateChannel( } return TCL_OK; } - + + /* *--------------------------------------------------------------------------- * @@ -7384,7 +7455,8 @@ CheckChannelErrors( return 0; } - + + /* *---------------------------------------------------------------------- * @@ -7410,7 +7482,8 @@ Tcl_Eof( return GotFlag(statePtr, CHANNEL_EOF) ? 1 : 0; } - + + /* *---------------------------------------------------------------------- * @@ -7436,7 +7509,8 @@ Tcl_InputBlocked( return GotFlag(statePtr, CHANNEL_BLOCKED) ? 1 : 0; } - + + /* *---------------------------------------------------------------------- * @@ -7480,7 +7554,8 @@ Tcl_InputBuffered( return bytesBuffered; } - + + /* *---------------------------------------------------------------------- * @@ -7522,7 +7597,8 @@ Tcl_OutputBuffered( return bytesBuffered; } - + + /* *---------------------------------------------------------------------- * @@ -7557,7 +7633,8 @@ Tcl_ChannelBuffered( return bytesBuffered; } - + + /* *---------------------------------------------------------------------- * @@ -7615,7 +7692,8 @@ Tcl_SetChannelBufferSize( statePtr->inQueueTail = NULL; } } - + + /* *---------------------------------------------------------------------- * @@ -7642,7 +7720,8 @@ Tcl_GetChannelBufferSize( return statePtr->bufSize; } - + + /* *---------------------------------------------------------------------- * @@ -7713,7 +7792,8 @@ Tcl_BadChannelOption( Tcl_SetErrno(EINVAL); return TCL_ERROR; } - + + /* *---------------------------------------------------------------------- * @@ -7945,7 +8025,8 @@ Tcl_GetChannelOption( return Tcl_BadChannelOption(interp, optionName, NULL); } } - + + /* *--------------------------------------------------------------------------- * @@ -8247,7 +8328,8 @@ Tcl_SetChannelOption( return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -8301,7 +8383,8 @@ CleanupChannelHandlers( } } } - + + /* *---------------------------------------------------------------------- * @@ -8459,7 +8542,8 @@ done: tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr; } - + + /* *---------------------------------------------------------------------- * @@ -8560,7 +8644,8 @@ UpdateInterest( } ChanWatch(chanPtr, mask); } - + + /* *---------------------------------------------------------------------- * @@ -8605,7 +8690,8 @@ ChannelTimerProc( UpdateInterest(chanPtr); } } - + + /* *---------------------------------------------------------------------- * @@ -8685,7 +8771,8 @@ Tcl_CreateChannelHandler( UpdateInterest(statePtr->topChanPtr); } - + + /* *---------------------------------------------------------------------- * @@ -8775,7 +8862,8 @@ Tcl_DeleteChannelHandler( UpdateInterest(statePtr->topChanPtr); } - + + /* *---------------------------------------------------------------------- * @@ -8826,7 +8914,8 @@ DeleteScriptRecord( } } } - + + /* *---------------------------------------------------------------------- * @@ -8894,7 +8983,8 @@ CreateScriptRecord( TclChannelEventScriptInvoker, esPtr); } } - + + /* *---------------------------------------------------------------------- * @@ -8962,7 +9052,8 @@ TclChannelEventScriptInvoker( TclChannelRelease((Tcl_Channel)chanPtr); Tcl_Release(interp); } - + + /* *---------------------------------------------------------------------- * @@ -9060,7 +9151,8 @@ Tcl_FileEventObjCmd( return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -9087,7 +9179,8 @@ ZeroTransferTimerProc( */ CopyData((CopyState *)clientData, 0); } - + + /* *---------------------------------------------------------------------- * @@ -9240,7 +9333,8 @@ TclCopyChannel( return CopyData(csPtr, 0); } - + + /* *---------------------------------------------------------------------- * @@ -9791,7 +9885,8 @@ CopyData( } return result; } - + + /* *---------------------------------------------------------------------- * @@ -10037,7 +10132,8 @@ DoRead( TclChannelRelease((Tcl_Channel)chanPtr); return (int)(p - dst); } - + + /* *---------------------------------------------------------------------- * @@ -10063,7 +10159,8 @@ CopyEventProc( { (void) CopyData((CopyState *)clientData, mask); } - + + /* *---------------------------------------------------------------------- * @@ -10132,7 +10229,8 @@ StopCopy( outStatePtr->csPtrW = NULL; ckfree(csPtr); } - + + /* *---------------------------------------------------------------------- * @@ -10181,7 +10279,8 @@ StackSetBlockMode( } return 0; } - + + /* *---------------------------------------------------------------------- * @@ -10249,7 +10348,8 @@ SetBlockMode( } return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -10272,7 +10372,8 @@ Tcl_GetChannelNames( { return Tcl_GetChannelNamesEx(interp, NULL); } - + + /* *---------------------------------------------------------------------- * @@ -10358,7 +10459,8 @@ Tcl_GetChannelNamesEx( Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -10408,7 +10510,8 @@ Tcl_IsChannelRegistered( return 1; } - + + /* *---------------------------------------------------------------------- * @@ -10434,7 +10537,8 @@ Tcl_IsChannelShared( return ((statePtr->refCount > 1) ? 1 : 0); } - + + /* *---------------------------------------------------------------------- * @@ -10483,7 +10587,8 @@ Tcl_IsChannelExisting( return 0; } - + + /* *---------------------------------------------------------------------- * @@ -10506,7 +10611,8 @@ Tcl_ChannelName( { return chanTypePtr->typeName; } - + + /* *---------------------------------------------------------------------- * @@ -10538,7 +10644,8 @@ Tcl_ChannelVersion( } return chanTypePtr->version; } - + + /* *---------------------------------------------------------------------- * @@ -10568,7 +10675,8 @@ Tcl_ChannelBlockModeProc( return chanTypePtr->blockModeProc; } - + + /* *---------------------------------------------------------------------- * @@ -10592,7 +10700,8 @@ Tcl_ChannelCloseProc( { return chanTypePtr->closeProc; } - + + /* *---------------------------------------------------------------------- * @@ -10616,7 +10725,8 @@ Tcl_ChannelClose2Proc( { return chanTypePtr->close2Proc; } - + + /* *---------------------------------------------------------------------- * @@ -10640,7 +10750,8 @@ Tcl_ChannelInputProc( { return chanTypePtr->inputProc; } - + + /* *---------------------------------------------------------------------- * @@ -10664,7 +10775,8 @@ Tcl_ChannelOutputProc( { return chanTypePtr->outputProc; } - + + /* *---------------------------------------------------------------------- * @@ -10688,7 +10800,8 @@ Tcl_ChannelSeekProc( { return chanTypePtr->seekProc; } - + + /* *---------------------------------------------------------------------- * @@ -10712,7 +10825,8 @@ Tcl_ChannelSetOptionProc( { return chanTypePtr->setOptionProc; } - + + /* *---------------------------------------------------------------------- * @@ -10736,7 +10850,8 @@ Tcl_ChannelGetOptionProc( { return chanTypePtr->getOptionProc; } - + + /* *---------------------------------------------------------------------- * @@ -10760,7 +10875,8 @@ Tcl_ChannelWatchProc( { return chanTypePtr->watchProc; } - + + /* *---------------------------------------------------------------------- * @@ -10784,7 +10900,8 @@ Tcl_ChannelGetHandleProc( { return chanTypePtr->getHandleProc; } - + + /* *---------------------------------------------------------------------- * @@ -10811,7 +10928,8 @@ Tcl_ChannelFlushProc( } return chanTypePtr->flushProc; } - + + /* *---------------------------------------------------------------------- * @@ -10838,7 +10956,8 @@ Tcl_ChannelHandlerProc( } return chanTypePtr->handlerProc; } - + + /* *---------------------------------------------------------------------- * @@ -10865,7 +10984,8 @@ Tcl_ChannelWideSeekProc( } return chanTypePtr->wideSeekProc; } - + + /* *---------------------------------------------------------------------- * @@ -10893,7 +11013,8 @@ Tcl_ChannelThreadActionProc( } return chanTypePtr->threadActionProc; } - + + /* *---------------------------------------------------------------------- * @@ -10929,7 +11050,8 @@ Tcl_SetChannelErrorInterp( } return; } - + + /* *---------------------------------------------------------------------- * @@ -10965,7 +11087,8 @@ Tcl_SetChannelError( } return; } - + + /* *---------------------------------------------------------------------- * @@ -11124,7 +11247,8 @@ FixLevelCode( ckfree(lvn); return msg; } - + + /* *---------------------------------------------------------------------- * @@ -11152,7 +11276,8 @@ Tcl_GetChannelErrorInterp( *msg = iPtr->chanMsg; iPtr->chanMsg = NULL; } - + + /* *---------------------------------------------------------------------- * @@ -11180,7 +11305,8 @@ Tcl_GetChannelError( *msg = statePtr->chanMsg; statePtr->chanMsg = NULL; } - + + /* *---------------------------------------------------------------------- * @@ -11208,7 +11334,8 @@ Tcl_ChannelTruncateProc( } return chanTypePtr->truncateProc; } - + + /* *---------------------------------------------------------------------- * @@ -11240,7 +11367,8 @@ DupChannelInternalRep( copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; copyPtr->typePtr = srcPtr->typePtr; } - + + /* *---------------------------------------------------------------------- * @@ -11270,7 +11398,8 @@ FreeChannelInternalRep( Tcl_Release(resPtr->statePtr); ckfree(resPtr); } - + + #if 0 /* * For future debugging work, a simple function to print the flags of a @@ -11308,7 +11437,8 @@ DumpFlags( return 0; } #endif - + + /* * Local Variables: * mode: c -- cgit v0.12 From 47699b8fff2e41463af41ad4aaece58038550955 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 22 Jul 2022 18:38:30 +0000 Subject: EOF seemed to reset INPUT_SAW_CR previously, so do it now explicitely (satisfying the test ?chan?io-6.46) --- generic/tclIO.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index e102675..e03b9c5 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4825,7 +4825,7 @@ Tcl_GetsObj( Tcl_SetObjLength(objPtr, oldLength); CommonGetsCleanup(chanPtr); copiedTotal = -1; - ResetFlag(statePtr, CHANNEL_BLOCKED); + ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); goto done; } goto gotEOL; -- cgit v0.12 From f7aabfbd54bdcb775c6a96d9ca20548c7dc8f360 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 22 Jul 2022 18:49:27 +0000 Subject: restore FF-char (fossil seems to loss form feed if commits with convertion from CRLF to LF) --- generic/tclIO.c | 387 +++++++++++++++++++------------------------------------- 1 file changed, 129 insertions(+), 258 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index e03b9c5..376ab36 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -340,8 +340,7 @@ static const Tcl_ObjType chanObjType = { (((st)->csPtrW) && ((fl) & TCL_WRITABLE))) #define MAX_CHANNEL_BUFFER_SIZE (1024*1024) - - + /* *--------------------------------------------------------------------------- * @@ -511,8 +510,7 @@ ChanWrite( return chanPtr->typePtr->outputProc(chanPtr->instanceData, src, srcLen, errnoPtr); } - - + /* *--------------------------------------------------------------------------- * @@ -540,8 +538,7 @@ TclInitIOSubsystem(void) (void) TCL_TSD_INIT(&dataKey); } - - + /* *------------------------------------------------------------------------- * @@ -687,8 +684,7 @@ TclFinalizeIOSubsystem(void) TclpFinalizeSockets(); TclpFinalizePipes(); } - - + /* *---------------------------------------------------------------------- * @@ -729,8 +725,7 @@ Tcl_SetStdChannel( break; } } - - + /* *---------------------------------------------------------------------- * @@ -806,8 +801,7 @@ Tcl_GetStdChannel( } return channel; } - - + /* *---------------------------------------------------------------------- * @@ -845,8 +839,7 @@ Tcl_CreateCloseHandler( cbPtr->nextPtr = statePtr->closeCbPtr; statePtr->closeCbPtr = cbPtr; } - - + /* *---------------------------------------------------------------------- * @@ -891,8 +884,7 @@ Tcl_DeleteCloseHandler( cbPrevPtr = cbPtr; } } - - + /* *---------------------------------------------------------------------- * @@ -948,8 +940,7 @@ GetChannelTable( } return hTblPtr; } - - + /* *---------------------------------------------------------------------- * @@ -1039,8 +1030,7 @@ DeleteChannelTable( Tcl_DeleteHashTable(hTblPtr); ckfree(hTblPtr); } - - + /* *---------------------------------------------------------------------- * @@ -1096,8 +1086,7 @@ CheckForStdChannelsBeingClosed( } } } - - + /* *---------------------------------------------------------------------- * @@ -1130,8 +1119,7 @@ Tcl_IsStandardChannel( return 0; } } - - + /* *---------------------------------------------------------------------- * @@ -1188,8 +1176,7 @@ Tcl_RegisterChannel( } statePtr->refCount++; } - - + /* *---------------------------------------------------------------------- * @@ -1274,8 +1261,7 @@ Tcl_UnregisterChannel( } return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -1321,8 +1307,7 @@ Tcl_DetachChannel( return DetachChannel(interp, chan); } - - + /* *---------------------------------------------------------------------- * @@ -1395,8 +1380,7 @@ DetachChannel( return TCL_OK; } - - + /* *--------------------------------------------------------------------------- * @@ -1478,8 +1462,7 @@ Tcl_GetChannel( return (Tcl_Channel) chanPtr; } - - + /* *--------------------------------------------------------------------------- * @@ -1575,8 +1558,7 @@ TclGetChannelFromObj( return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -1784,8 +1766,7 @@ Tcl_CreateChannel( } return (Tcl_Channel) chanPtr; } - - + /* *---------------------------------------------------------------------- * @@ -2014,8 +1995,7 @@ ChannelFree( } chanPtr->typePtr = NULL; } - - + /* *---------------------------------------------------------------------- * @@ -2203,8 +2183,7 @@ Tcl_UnstackChannel( return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -2232,8 +2211,7 @@ Tcl_GetStackedChannel( return (Tcl_Channel) chanPtr->downChanPtr; } - - + /* *---------------------------------------------------------------------- * @@ -2261,8 +2239,7 @@ Tcl_GetTopChannel( return (Tcl_Channel) chanPtr->state->topChanPtr; } - - + /* *---------------------------------------------------------------------- * @@ -2288,8 +2265,7 @@ Tcl_GetChannelInstanceData( return chanPtr->instanceData; } - - + /* *---------------------------------------------------------------------- * @@ -2316,8 +2292,7 @@ Tcl_GetChannelThread( return chanPtr->state->managingThread; } - - + /* *---------------------------------------------------------------------- * @@ -2343,8 +2318,7 @@ Tcl_GetChannelType( return chanPtr->typePtr; } - - + /* *---------------------------------------------------------------------- * @@ -2372,8 +2346,7 @@ Tcl_GetChannelMode( return (statePtr->flags & (TCL_READABLE | TCL_WRITABLE)); } - - + /* *---------------------------------------------------------------------- * @@ -2400,8 +2373,7 @@ Tcl_GetChannelName( return statePtr->channelName; } - - + /* *---------------------------------------------------------------------- * @@ -2443,8 +2415,7 @@ Tcl_GetChannelHandle( } return result; } - - + /* *--------------------------------------------------------------------------- * @@ -2512,8 +2483,7 @@ IsShared( { return bufPtr->refCount > 1; } - - + /* *---------------------------------------------------------------------- * @@ -2602,8 +2572,7 @@ RecycleBuffer( bufPtr->nextAdded = BUFFER_PADDING; bufPtr->nextPtr = NULL; } - - + /* *---------------------------------------------------------------------- * @@ -2639,8 +2608,7 @@ DiscardOutputQueued( RecycleBuffer(statePtr, bufPtr, 0); } } - - + /* *---------------------------------------------------------------------- * @@ -2674,8 +2642,7 @@ CheckForDeadChannel( } return 1; } - - + /* *---------------------------------------------------------------------- * @@ -2977,8 +2944,7 @@ FlushChannel( TclChannelRelease((Tcl_Channel)chanPtr); return errorCode; } - - + /* *---------------------------------------------------------------------- * @@ -3159,8 +3125,7 @@ CloseChannel( return errorCode; } - - + /* *---------------------------------------------------------------------- * @@ -3275,8 +3240,7 @@ Tcl_CutChannel( /* Channel is not managed by any thread */ statePtr->managingThread = NULL; } - - + /* *---------------------------------------------------------------------- * @@ -3366,8 +3330,7 @@ Tcl_SpliceChannel( ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_INSERT); } } - - + /* *---------------------------------------------------------------------- * @@ -3561,8 +3524,7 @@ Tcl_Close( } return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -3696,8 +3658,7 @@ Tcl_CloseEx( return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -3773,8 +3734,7 @@ CloseWrite( return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -3910,8 +3870,7 @@ CloseChannelPart( ResetFlag(statePtr, flags & (TCL_READABLE | TCL_WRITABLE)); return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -4005,8 +3964,7 @@ Tcl_ClearChannelHandlers( } statePtr->scriptRecordPtr = NULL; } - - + /* *---------------------------------------------------------------------- * @@ -4060,8 +4018,7 @@ Tcl_Write( } return srcLen; } - - + /* *---------------------------------------------------------------------- * @@ -4118,8 +4075,7 @@ Tcl_WriteRaw( return written; } - - + /* *--------------------------------------------------------------------------- * @@ -4186,8 +4142,7 @@ Tcl_WriteChars( TclDecrRefCount(objPtr); return result; } - - + /* *--------------------------------------------------------------------------- * @@ -4241,8 +4196,7 @@ Tcl_WriteObj( return WriteChars(chanPtr, src, srcLen); } } - - + static void WillWrite( Channel *chanPtr) @@ -4257,8 +4211,7 @@ WillWrite( ChanSeek(chanPtr, -inputBuffered, SEEK_CUR, &ignore); } } - - + static int WillRead( Channel *chanPtr) @@ -4291,8 +4244,7 @@ WillRead( } return 0; } - - + /* *---------------------------------------------------------------------- * @@ -4492,8 +4444,7 @@ Write( return total; } - - + /* *--------------------------------------------------------------------------- * @@ -4532,8 +4483,7 @@ Tcl_Gets( TclDecrRefCount(objPtr); return charsStored; } - - + /* *--------------------------------------------------------------------------- * @@ -4946,8 +4896,7 @@ Tcl_GetsObj( TclChannelRelease((Tcl_Channel)chanPtr); return copiedTotal; } - - + /* *--------------------------------------------------------------------------- * @@ -5221,8 +5170,7 @@ TclGetsObjBinary( TclChannelRelease((Tcl_Channel)chanPtr); return copiedTotal; } - - + /* *--------------------------------------------------------------------------- * @@ -5264,8 +5212,7 @@ GetBinaryEncoding() } return tsdPtr->binaryEncoding; } - - + /* *--------------------------------------------------------------------------- * @@ -5458,8 +5405,7 @@ FilterInputBytes( gsPtr->bufPtr = bufPtr; return 0; } - - + /* *--------------------------------------------------------------------------- * @@ -5544,8 +5490,7 @@ PeekAhead( gsPtr->bytesWrote = 0; gsPtr->charsWrote = 0; } - - + /* *--------------------------------------------------------------------------- * @@ -5608,8 +5553,7 @@ CommonGetsCleanup( } } } - - + /* *---------------------------------------------------------------------- * @@ -5654,8 +5598,7 @@ Tcl_Read( return DoRead(chanPtr, dst, bytesToRead, 0); } - - + /* *---------------------------------------------------------------------- * @@ -5773,8 +5716,7 @@ Tcl_ReadRaw( } return copied; } - - + /* *--------------------------------------------------------------------------- * @@ -6029,8 +5971,7 @@ DoReadChars( TclChannelRelease((Tcl_Channel)chanPtr); return copied; } - - + /* *--------------------------------------------------------------------------- * @@ -6079,8 +6020,7 @@ ReadBytes( bufPtr->nextRemoved += toRead; return toRead; } - - + /* *--------------------------------------------------------------------------- * @@ -6483,8 +6423,7 @@ ReadChars( return numChars; } } - - + /* *--------------------------------------------------------------------------- * @@ -6660,8 +6599,7 @@ TranslateInputEOL( ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); } } - - + /* *---------------------------------------------------------------------- * @@ -6749,8 +6687,7 @@ Tcl_Ungets( UpdateInterest(chanPtr); return len; } - - + /* *---------------------------------------------------------------------- * @@ -6794,8 +6731,7 @@ Tcl_Flush( return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -6842,8 +6778,7 @@ DiscardInputQueued( statePtr->saveInBufPtr = NULL; } } - - + /* *--------------------------------------------------------------------------- * @@ -6992,8 +6927,7 @@ GetInput( ReleaseChannelBuffer(bufPtr); return result; } - - + /* *---------------------------------------------------------------------- * @@ -7161,8 +7095,7 @@ Tcl_Seek( return curPos; } - - + /* *---------------------------------------------------------------------- * @@ -7251,8 +7184,7 @@ Tcl_Tell( } return curPos + outputBuffered; } - - + /* *--------------------------------------------------------------------------- * @@ -7293,8 +7225,7 @@ Tcl_TellOld( return (int) Tcl_WideAsLong(wResult); } - - + /* *--------------------------------------------------------------------------- * @@ -7366,8 +7297,7 @@ Tcl_TruncateChannel( } return TCL_OK; } - - + /* *--------------------------------------------------------------------------- * @@ -7455,8 +7385,7 @@ CheckChannelErrors( return 0; } - - + /* *---------------------------------------------------------------------- * @@ -7482,8 +7411,7 @@ Tcl_Eof( return GotFlag(statePtr, CHANNEL_EOF) ? 1 : 0; } - - + /* *---------------------------------------------------------------------- * @@ -7509,8 +7437,7 @@ Tcl_InputBlocked( return GotFlag(statePtr, CHANNEL_BLOCKED) ? 1 : 0; } - - + /* *---------------------------------------------------------------------- * @@ -7554,8 +7481,7 @@ Tcl_InputBuffered( return bytesBuffered; } - - + /* *---------------------------------------------------------------------- * @@ -7597,8 +7523,7 @@ Tcl_OutputBuffered( return bytesBuffered; } - - + /* *---------------------------------------------------------------------- * @@ -7633,8 +7558,7 @@ Tcl_ChannelBuffered( return bytesBuffered; } - - + /* *---------------------------------------------------------------------- * @@ -7692,8 +7616,7 @@ Tcl_SetChannelBufferSize( statePtr->inQueueTail = NULL; } } - - + /* *---------------------------------------------------------------------- * @@ -7720,8 +7643,7 @@ Tcl_GetChannelBufferSize( return statePtr->bufSize; } - - + /* *---------------------------------------------------------------------- * @@ -7792,8 +7714,7 @@ Tcl_BadChannelOption( Tcl_SetErrno(EINVAL); return TCL_ERROR; } - - + /* *---------------------------------------------------------------------- * @@ -8025,8 +7946,7 @@ Tcl_GetChannelOption( return Tcl_BadChannelOption(interp, optionName, NULL); } } - - + /* *--------------------------------------------------------------------------- * @@ -8328,8 +8248,7 @@ Tcl_SetChannelOption( return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -8383,8 +8302,7 @@ CleanupChannelHandlers( } } } - - + /* *---------------------------------------------------------------------- * @@ -8542,8 +8460,7 @@ done: tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr; } - - + /* *---------------------------------------------------------------------- * @@ -8644,8 +8561,7 @@ UpdateInterest( } ChanWatch(chanPtr, mask); } - - + /* *---------------------------------------------------------------------- * @@ -8690,8 +8606,7 @@ ChannelTimerProc( UpdateInterest(chanPtr); } } - - + /* *---------------------------------------------------------------------- * @@ -8771,8 +8686,7 @@ Tcl_CreateChannelHandler( UpdateInterest(statePtr->topChanPtr); } - - + /* *---------------------------------------------------------------------- * @@ -8862,8 +8776,7 @@ Tcl_DeleteChannelHandler( UpdateInterest(statePtr->topChanPtr); } - - + /* *---------------------------------------------------------------------- * @@ -8914,8 +8827,7 @@ DeleteScriptRecord( } } } - - + /* *---------------------------------------------------------------------- * @@ -8983,8 +8895,7 @@ CreateScriptRecord( TclChannelEventScriptInvoker, esPtr); } } - - + /* *---------------------------------------------------------------------- * @@ -9052,8 +8963,7 @@ TclChannelEventScriptInvoker( TclChannelRelease((Tcl_Channel)chanPtr); Tcl_Release(interp); } - - + /* *---------------------------------------------------------------------- * @@ -9151,8 +9061,7 @@ Tcl_FileEventObjCmd( return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -9179,8 +9088,7 @@ ZeroTransferTimerProc( */ CopyData((CopyState *)clientData, 0); } - - + /* *---------------------------------------------------------------------- * @@ -9333,8 +9241,7 @@ TclCopyChannel( return CopyData(csPtr, 0); } - - + /* *---------------------------------------------------------------------- * @@ -9885,8 +9792,7 @@ CopyData( } return result; } - - + /* *---------------------------------------------------------------------- * @@ -10132,8 +10038,7 @@ DoRead( TclChannelRelease((Tcl_Channel)chanPtr); return (int)(p - dst); } - - + /* *---------------------------------------------------------------------- * @@ -10159,8 +10064,7 @@ CopyEventProc( { (void) CopyData((CopyState *)clientData, mask); } - - + /* *---------------------------------------------------------------------- * @@ -10229,8 +10133,7 @@ StopCopy( outStatePtr->csPtrW = NULL; ckfree(csPtr); } - - + /* *---------------------------------------------------------------------- * @@ -10279,8 +10182,7 @@ StackSetBlockMode( } return 0; } - - + /* *---------------------------------------------------------------------- * @@ -10348,8 +10250,7 @@ SetBlockMode( } return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -10372,8 +10273,7 @@ Tcl_GetChannelNames( { return Tcl_GetChannelNamesEx(interp, NULL); } - - + /* *---------------------------------------------------------------------- * @@ -10459,8 +10359,7 @@ Tcl_GetChannelNamesEx( Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } - - + /* *---------------------------------------------------------------------- * @@ -10510,8 +10409,7 @@ Tcl_IsChannelRegistered( return 1; } - - + /* *---------------------------------------------------------------------- * @@ -10537,8 +10435,7 @@ Tcl_IsChannelShared( return ((statePtr->refCount > 1) ? 1 : 0); } - - + /* *---------------------------------------------------------------------- * @@ -10587,8 +10484,7 @@ Tcl_IsChannelExisting( return 0; } - - + /* *---------------------------------------------------------------------- * @@ -10611,8 +10507,7 @@ Tcl_ChannelName( { return chanTypePtr->typeName; } - - + /* *---------------------------------------------------------------------- * @@ -10644,8 +10539,7 @@ Tcl_ChannelVersion( } return chanTypePtr->version; } - - + /* *---------------------------------------------------------------------- * @@ -10675,8 +10569,7 @@ Tcl_ChannelBlockModeProc( return chanTypePtr->blockModeProc; } - - + /* *---------------------------------------------------------------------- * @@ -10700,8 +10593,7 @@ Tcl_ChannelCloseProc( { return chanTypePtr->closeProc; } - - + /* *---------------------------------------------------------------------- * @@ -10725,8 +10617,7 @@ Tcl_ChannelClose2Proc( { return chanTypePtr->close2Proc; } - - + /* *---------------------------------------------------------------------- * @@ -10750,8 +10641,7 @@ Tcl_ChannelInputProc( { return chanTypePtr->inputProc; } - - + /* *---------------------------------------------------------------------- * @@ -10775,8 +10665,7 @@ Tcl_ChannelOutputProc( { return chanTypePtr->outputProc; } - - + /* *---------------------------------------------------------------------- * @@ -10800,8 +10689,7 @@ Tcl_ChannelSeekProc( { return chanTypePtr->seekProc; } - - + /* *---------------------------------------------------------------------- * @@ -10825,8 +10713,7 @@ Tcl_ChannelSetOptionProc( { return chanTypePtr->setOptionProc; } - - + /* *---------------------------------------------------------------------- * @@ -10850,8 +10737,7 @@ Tcl_ChannelGetOptionProc( { return chanTypePtr->getOptionProc; } - - + /* *---------------------------------------------------------------------- * @@ -10875,8 +10761,7 @@ Tcl_ChannelWatchProc( { return chanTypePtr->watchProc; } - - + /* *---------------------------------------------------------------------- * @@ -10900,8 +10785,7 @@ Tcl_ChannelGetHandleProc( { return chanTypePtr->getHandleProc; } - - + /* *---------------------------------------------------------------------- * @@ -10928,8 +10812,7 @@ Tcl_ChannelFlushProc( } return chanTypePtr->flushProc; } - - + /* *---------------------------------------------------------------------- * @@ -10956,8 +10839,7 @@ Tcl_ChannelHandlerProc( } return chanTypePtr->handlerProc; } - - + /* *---------------------------------------------------------------------- * @@ -10984,8 +10866,7 @@ Tcl_ChannelWideSeekProc( } return chanTypePtr->wideSeekProc; } - - + /* *---------------------------------------------------------------------- * @@ -11013,8 +10894,7 @@ Tcl_ChannelThreadActionProc( } return chanTypePtr->threadActionProc; } - - + /* *---------------------------------------------------------------------- * @@ -11050,8 +10930,7 @@ Tcl_SetChannelErrorInterp( } return; } - - + /* *---------------------------------------------------------------------- * @@ -11087,8 +10966,7 @@ Tcl_SetChannelError( } return; } - - + /* *---------------------------------------------------------------------- * @@ -11247,8 +11125,7 @@ FixLevelCode( ckfree(lvn); return msg; } - - + /* *---------------------------------------------------------------------- * @@ -11276,8 +11153,7 @@ Tcl_GetChannelErrorInterp( *msg = iPtr->chanMsg; iPtr->chanMsg = NULL; } - - + /* *---------------------------------------------------------------------- * @@ -11305,8 +11181,7 @@ Tcl_GetChannelError( *msg = statePtr->chanMsg; statePtr->chanMsg = NULL; } - - + /* *---------------------------------------------------------------------- * @@ -11334,8 +11209,7 @@ Tcl_ChannelTruncateProc( } return chanTypePtr->truncateProc; } - - + /* *---------------------------------------------------------------------- * @@ -11367,8 +11241,7 @@ DupChannelInternalRep( copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; copyPtr->typePtr = srcPtr->typePtr; } - - + /* *---------------------------------------------------------------------- * @@ -11398,8 +11271,7 @@ FreeChannelInternalRep( Tcl_Release(resPtr->statePtr); ckfree(resPtr); } - - + #if 0 /* * For future debugging work, a simple function to print the flags of a @@ -11437,8 +11309,7 @@ DumpFlags( return 0; } #endif - - + /* * Local Variables: * mode: c -- cgit v0.12 From 49867f2fd30037c8b87e75e9bef5c7424edfe15f Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 22 Jul 2022 19:19:26 +0000 Subject: =?UTF-8?q?correctly=20show=20the=20execution=20time=20unit=20by?= =?UTF-8?q?=20usec=20(=C2=B5s)=20if=20testing=20on=20systems=20with=20not?= =?UTF-8?q?=20utf-8=20default=20system=20encoding=20(e.=20g.=20windows)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- library/tcltest/tcltest.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 72c7b94..9124699 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2141,7 +2141,7 @@ proc tcltest::test {name description args} { if {[IsVerbose msec] || [IsVerbose usec]} { set t [expr {[clock microseconds] - $timeStart}] if {[IsVerbose usec]} { - puts [outputChannel] "++++ $name took $t μs" + puts [outputChannel] "++++ $name took $t \xB5s" } if {[IsVerbose msec]} { puts [outputChannel] "++++ $name took [expr {round($t/1000.)}] ms" -- cgit v0.12 From 518ff0b0d9cbf5887984531c88f896be53454d2e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 22 Jul 2022 21:42:24 +0000 Subject: tcltest 2.5.4 -> 2.5.5 --- library/tcltest/pkgIndex.tcl | 2 +- library/tcltest/tcltest.tcl | 2 +- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index da78df0..18b05e5 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5-]} {return} -package ifneeded tcltest 2.5.4 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.5.5 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 9124699..7344f9f 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.5.4 + variable Version 2.5.5 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] diff --git a/unix/Makefile.in b/unix/Makefile.in index 23383cd..316ec22 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -960,9 +960,9 @@ install-libraries: libraries @echo "Installing package msgcat 1.6.1 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \ "$(MODULE_INSTALL_DIR)/8.5/msgcat-1.6.1.tm" - @echo "Installing package tcltest 2.5.4 as a Tcl Module" + @echo "Installing package tcltest 2.5.5 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \ - "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.4.tm" + "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.5.tm" @echo "Installing package platform 1.0.18 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \ "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.18.tm" diff --git a/win/Makefile.in b/win/Makefile.in index 08fb1b5..73387e3 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -744,8 +744,8 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing package msgcat 1.6.1 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl "$(MODULE_INSTALL_DIR)/8.5/msgcat-1.6.1.tm"; - @echo "Installing package tcltest 2.5.4 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.4.tm"; + @echo "Installing package tcltest 2.5.5 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.5.tm"; @echo "Installing package platform 1.0.18 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.18.tm"; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; -- cgit v0.12 From 62e24a0269129ae00a2ad1aab8ed9667af46f0b8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 25 Jul 2022 13:57:37 +0000 Subject: execvpw/seteuidw don't exist. Fix some other signatures in compat/unistd.h --- compat/unistd.h | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/compat/unistd.h b/compat/unistd.h index a8f14f2..1725590 100644 --- a/compat/unistd.h +++ b/compat/unistd.h @@ -17,7 +17,7 @@ #include #ifndef NULL -#define NULL 0 +# define NULL 0 #endif /* @@ -35,9 +35,9 @@ extern int dup2(int oldfd, int newfd); extern int execl(const char *path, ...); extern int execle(const char *path, ...); extern int execlp(const char *file, ...); -extern int execv(const char *path, char **argv); -extern int execve(const char *path, char **argv, char **envp); -extern int execvpw(const char *file, char **argv); +extern int execv(const char *path, char *const argv[]); +extern int execve(const char *path, char *const argv[], char *const *envp); +extern int execvp(const char *file, char *const argv[]); extern pid_t fork(void); extern char * getcwd(char *buf, size_t size); extern gid_t getegid(void); @@ -65,7 +65,7 @@ extern int ftruncate(int fd, unsigned long length); extern int ioctl(int fd, int request, ...); extern int readlink(const char *path, char *buf, int bufsize); extern int setegid(gid_t group); -extern int seteuidw(uid_t user); +extern int seteuid(uid_t user); extern int setreuid(int ruid, int euid); extern int symlink(const char *, const char *); extern int ttyslot(void); -- cgit v0.12 From 856edbc25be9401b87ea00c346b7bea728e8c0dd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 25 Jul 2022 21:12:10 +0000 Subject: Make testapplylambda work on Windows with gcc too --- tests/apply.test | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests/apply.test b/tests/apply.test index 32dff08..a5f1f8f 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -16,6 +16,8 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] if {[info commands ::apply] eq {}} { return -- cgit v0.12 From a66ed8e23823b7ddefdb8867d3f4d5dc5dfd44d6 Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 27 Jul 2022 15:56:13 +0000 Subject: fixes [4eb3a155ac] and similar segfaults: reset corresponding bodyPtr->procPtr if procPtr gets released in TclProcCleanupProc, also recompile body if its procPtr is not the same as supplied. --- generic/tclProc.c | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index 59153b8..7550bfa 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1576,13 +1576,16 @@ TclPushProcCallFrame( * is up-to-date), the namespace must match (so variable handling * is right) and the resolverEpoch must match (so that new shadowed * commands and/or resolver changes are considered). + * Ensure the ByteCode's procPtr is the same (or it's precompiled). */ codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) - || (codePtr->nsEpoch != nsPtr->resolverEpoch)) { + || (codePtr->nsEpoch != nsPtr->resolverEpoch) + || ((codePtr->procPtr != procPtr) && procPtr->bodyPtr->bytes) + ) { goto doCompilation; } } else { @@ -1920,6 +1923,7 @@ TclProcCompileProc( * procPtr->numCompiledLocals if new local variables are found while * compiling. * + * Ensure the ByteCode's procPtr is the same (or it is pure precompiled). * Precompiled procedure bodies, however, are immutable and therefore they * are not recompiled, even if things have changed. */ @@ -1928,7 +1932,9 @@ TclProcCompileProc( if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == nsPtr) - && (codePtr->nsEpoch == nsPtr->resolverEpoch)) { + && (codePtr->nsEpoch == nsPtr->resolverEpoch) + && ((codePtr->procPtr == procPtr) || !bodyPtr->bytes) + ) { return TCL_OK; } @@ -2139,6 +2145,13 @@ TclProcCleanupProc( Interp *iPtr = procPtr->iPtr; if (bodyPtr != NULL) { + /* procPtr is stored in body's ByteCode, so ensure to reset it. */ + if (bodyPtr->typePtr == &tclByteCodeType) { + ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; + if (codePtr->procPtr == procPtr) { + codePtr->procPtr = NULL; + } + } Tcl_DecrRefCount(bodyPtr); } for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) { -- cgit v0.12 From 2da979cd8e0bfb96bc57578f2ff2413efd393e5c Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 29 Jul 2022 10:55:37 +0000 Subject: amend for [4eb3a155ac] SF-fix: 8.7 specific implementation and warnings silencing --- generic/tclProc.c | 10 +++++----- generic/tclTest.c | 6 +++--- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index 311ea4e..e6b1372 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -2162,11 +2162,11 @@ TclProcCleanupProc( if (bodyPtr != NULL) { /* procPtr is stored in body's ByteCode, so ensure to reset it. */ - if (bodyPtr->typePtr == &tclByteCodeType) { - ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; - if (codePtr->procPtr == procPtr) { - codePtr->procPtr = NULL; - } + ByteCode *codePtr; + + ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr); + if (codePtr != NULL && codePtr->procPtr == procPtr) { + codePtr->procPtr = NULL; } Tcl_DecrRefCount(bodyPtr); } diff --git a/generic/tclTest.c b/generic/tclTest.c index 77540e2..ed5f34b 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -8145,10 +8145,10 @@ TestInterpResolverCmd( *------------------------------------------------------------------------ */ int TestApplyLambdaObjCmd ( - ClientData notUsed, + TCL_UNUSED(void*), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + TCL_UNUSED(int), /* objc. */ + TCL_UNUSED(Tcl_Obj *const *)) /* objv. */ { Tcl_Obj *lambdaObjs[2]; Tcl_Obj *evalObjs[2]; -- cgit v0.12 From 7c269c207f4a9c13dd64edea5fa799a5d952742c Mon Sep 17 00:00:00 2001 From: max Date: Thu, 4 Aug 2022 15:09:59 +0000 Subject: Fix a case of lf not being flushed in certain cases when the crlf sequence gets split across two buffers on channels in crlf mode with line buffering [https://core.tcl-lang.org/tcllib/tktview?name=c9d8a52fe] --- generic/tclIO.c | 4 ++-- tests/io.test | 9 +++++++++ 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 376ab36..6b7ccdf 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4435,8 +4435,8 @@ Write( } ReleaseChannelBuffer(bufPtr); } - if ((flushed < total) && (GotFlag(statePtr, CHANNEL_UNBUFFERED) || - (needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED)))) { + if (((flushed < total) && GotFlag(statePtr, CHANNEL_UNBUFFERED)) || + (needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED))) { if (FlushChannel(NULL, chanPtr, 0) != 0) { return -1; } diff --git a/tests/io.test b/tests/io.test index 3b374c1..0a34019 100644 --- a/tests/io.test +++ b/tests/io.test @@ -330,6 +330,15 @@ test io-3.8 {WriteChars: reset sawLF after each buffer} { close $f lappend x [contents $path(test1)] } [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"] +test io-3.9 {Write: flush line-buffered channels when crlf is split over two buffers} -body { + # https://core.tcl-lang.org/tcllib/tktedit?name=c9d8a52fe + set f [open $path(test1) w] + fconfigure $f -buffering line -translation crlf -buffersize 8 + puts $f "1234567" + string map {"\r" "" "\n" ""} [contents $path(test1)] +} -cleanup { + close $f +} -result "1234567" test io-4.1 {TranslateOutputEOL: lf} { # search for \n -- cgit v0.12 From da40e7deb9d3e26315a495419b6ed50f0099bdc7 Mon Sep 17 00:00:00 2001 From: sebres Date: Sat, 20 Aug 2022 10:13:04 +0000 Subject: closes [baa51423c28a3baf]: needEvent must be initialized in cycle (for each watching channel) --- win/tclWinConsole.c | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 23652de..30a09fd 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -861,21 +861,25 @@ ConsoleCheckProc( handleInfoPtr = FindConsoleInfo(chanInfoPtr); /* Pointer is safe to access as we are holding gConsoleLock */ - if (handleInfoPtr != NULL) { - AcquireSRWLockShared(&handleInfoPtr->lock); - /* Rememebr channel is read or write, never both */ - if (chanInfoPtr->watchMask & TCL_READABLE) { - if (RingBufferLength(&handleInfoPtr->buffer) > 0 - || handleInfoPtr->lastError != ERROR_SUCCESS) { - needEvent = 1; /* Input data available or error/EOF */ - } - } else if (chanInfoPtr->watchMask & TCL_WRITABLE) { - if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) { - needEvent = 1; /* Output space available */ - } + if (handleInfoPtr == NULL) { + continue; + } + + needEvent = 0; + AcquireSRWLockShared(&handleInfoPtr->lock); + /* Rememebr channel is read or write, never both */ + if (chanInfoPtr->watchMask & TCL_READABLE) { + if (RingBufferLength(&handleInfoPtr->buffer) > 0 + || handleInfoPtr->lastError != ERROR_SUCCESS + ) { + needEvent = 1; /* Input data available or error/EOF */ + } + } else if (chanInfoPtr->watchMask & TCL_WRITABLE) { + if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) { + needEvent = 1; /* Output space available */ } - ReleaseSRWLockShared(&handleInfoPtr->lock); } + ReleaseSRWLockShared(&handleInfoPtr->lock); if (needEvent) { ConsoleEvent *evPtr = (ConsoleEvent *)ckalloc(sizeof(ConsoleEvent)); -- cgit v0.12 From b00b14a7fd336ad3a98519a59657d143e4ef1ae0 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 20 Aug 2022 12:16:10 +0000 Subject: Really closes [baa51423c28a3baf] --- win/tclWinConsole.c | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 30a09fd..0e38c5b 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -862,19 +862,26 @@ ConsoleCheckProc( /* Pointer is safe to access as we are holding gConsoleLock */ if (handleInfoPtr == NULL) { + /* Stale event */ continue; } - + needEvent = 0; AcquireSRWLockShared(&handleInfoPtr->lock); - /* Rememebr channel is read or write, never both */ + /* Rememeber channel is read or write, never both */ if (chanInfoPtr->watchMask & TCL_READABLE) { if (RingBufferLength(&handleInfoPtr->buffer) > 0 - || handleInfoPtr->lastError != ERROR_SUCCESS - ) { + || handleInfoPtr->lastError != ERROR_SUCCESS) { needEvent = 1; /* Input data available or error/EOF */ } - } else if (chanInfoPtr->watchMask & TCL_WRITABLE) { + /* + * TCL_READABLE watch means someone is looking out for data being + * available, let reader thread know. + */ + handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; + WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + } + else if (chanInfoPtr->watchMask & TCL_WRITABLE) { if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) { needEvent = 1; /* Output space available */ } -- cgit v0.12 From 839d38fbba493c388c1d261f9b47b8b38e2b7cb4 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 20 Aug 2022 16:56:10 +0000 Subject: Added test for bug [baa51423c2] --- tests/winConsole.test | 46 +++++++++++++++++++++++++++++++++++++++++----- win/tclWinConsole.c | 3 ++- 2 files changed, 43 insertions(+), 6 deletions(-) diff --git a/tests/winConsole.test b/tests/winConsole.test index 0daf54c..821a143 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -52,13 +52,21 @@ test console-input-1.0 {Console blocking gets} -constraints {win interactive} -b test console-input-1.1 {Console file channel: non-blocking gets} -constraints { win interactive +} -setup { + unset -nocomplain result + unset -nocomplain result2 } -body { set oldmode [fconfigure stdin] prompt "Type \"abc\" and hit Enter: " fileevent stdin readable { if {[gets stdin line] >= 0} { - set result $line + lappend result2 $line + if {[llength $result2] > 1} { + set result $result2 + } else { + prompt "Type \"def\" and hit Enter: " + } } elseif {[eof stdin]} { set result "gets failed" } @@ -66,7 +74,6 @@ test console-input-1.1 {Console file channel: non-blocking gets} -constraints { fconfigure stdin -blocking 0 -buffering line - set result {} vwait result #cleanup the fileevent @@ -74,7 +81,35 @@ test console-input-1.1 {Console file channel: non-blocking gets} -constraints { fconfigure stdin {*}$oldmode set result -} -result abc +} -result {abc def} + +test console-input-1.1.1 {Bug baa51423c28a: Console file channel: fileevent with blocking gets} -constraints { + win interactive +} -setup { + unset -nocomplain result + unset -nocomplain result2 +} -body { + prompt "Type \"abc\" and hit Enter: " + fileevent stdin readable { + if {[gets stdin line] >= 0} { + lappend result2 $line + if {[llength $result2] > 1} { + set result $result2 + } else { + prompt "Type \"def\" and hit Enter: " + } + } elseif {[eof stdin]} { + set result "gets failed" + } + } + + vwait result + + #cleanup the fileevent + fileevent stdin readable {} + set result + +} -result {abc def} test console-input-2.0 {Console blocking read} -constraints {win interactive} -setup { set oldmode [fconfigure stdin] @@ -94,6 +129,7 @@ test console-input-2.1 {Console file channel: non-blocking read} -constraints { set oldmode [fconfigure stdin] } -cleanup { fconfigure stdin {*}$oldmode + puts ""; # Because CRLF also would not have been echoed } -body { set input "" fconfigure stdin -blocking 0 -buffering line -inputmode raw @@ -262,10 +298,10 @@ test console-fconfigure-set-1.1 { fconfigure stdin -inputmode normal lappend result [yesno "\nWere the characters echoed?"] - prompt "\nType the keys \"c\", Ctrl-H, \"d\" and hit Enter. You should see characters echoed: " + prompt "Type the keys \"c\", Ctrl-H, \"d\" and hit Enter. You should see characters echoed: " lappend result [gets stdin] lappend result [fconfigure stdin -inputmode] - lappend result [yesno "\nWere the characters echoed (c replaced by d)?"] + lappend result [yesno "Were the characters echoed (c replaced by d)?"] set result } -result [list a\x08b raw 0 d normal 1] diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 0e38c5b..4b2d1d3 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -876,7 +876,8 @@ ConsoleCheckProc( } /* * TCL_READABLE watch means someone is looking out for data being - * available, let reader thread know. + * available, let reader thread know. Note channel need not be + * ASYNC! (Bug [baa51423c2]) */ handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; WakeConditionVariable(&handleInfoPtr->consoleThreadCV); -- cgit v0.12 From 02c762f9ec9e806dbd2b392e0f19a035b7da31f2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 21 Aug 2022 20:28:57 +0000 Subject: ClientData -> 'void *" in TclOO headers --- generic/tclOO.h | 10 ++++---- generic/tclOOInt.h | 68 +++++++++++++++++++++++++++--------------------------- 2 files changed, 39 insertions(+), 39 deletions(-) diff --git a/generic/tclOO.h b/generic/tclOO.h index a5c67b3..20dc281 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -60,12 +60,12 @@ typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext; * and to allow the attachment of arbitrary data to objects and classes. */ -typedef int (Tcl_MethodCallProc)(ClientData clientData, Tcl_Interp *interp, +typedef int (Tcl_MethodCallProc)(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv); -typedef void (Tcl_MethodDeleteProc)(ClientData clientData); -typedef int (Tcl_CloneProc)(Tcl_Interp *interp, ClientData oldClientData, - ClientData *newClientData); -typedef void (Tcl_ObjectMetadataDeleteProc)(ClientData clientData); +typedef void (Tcl_MethodDeleteProc)(void *clientData); +typedef int (Tcl_CloneProc)(Tcl_Interp *interp, void *oldClientData, + void **newClientData); +typedef void (Tcl_ObjectMetadataDeleteProc)(void *clientData); typedef int (Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp, Tcl_Object object, Tcl_Class *startClsPtr, Tcl_Obj *methodNameObj); diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index f061bc6..2931044 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -47,7 +47,7 @@ typedef struct Method { * special flag record which is just used for * the setting of the flags field. */ int refCount; - ClientData clientData; /* Type-specific data. */ + void *clientData; /* Type-specific data. */ Tcl_Obj *namePtr; /* Name of the method. */ struct Object *declaringObjectPtr; /* The object that declares this method, or @@ -65,12 +65,12 @@ typedef struct Method { * tuned in their behaviour. */ -typedef int (TclOO_PreCallProc)(ClientData clientData, Tcl_Interp *interp, +typedef int (TclOO_PreCallProc)(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, Tcl_CallFrame *framePtr, int *isFinished); -typedef int (TclOO_PostCallProc)(ClientData clientData, Tcl_Interp *interp, +typedef int (TclOO_PostCallProc)(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, Tcl_Namespace *namespacePtr, int result); -typedef void (TclOO_PmCDDeleteProc)(ClientData clientData); -typedef ClientData (TclOO_PmCDCloneProc)(ClientData clientData); +typedef void (TclOO_PmCDDeleteProc)(void *clientData); +typedef void *(TclOO_PmCDCloneProc)(void *clientData); /* * Procedure-like methods have the following extra information. @@ -84,7 +84,7 @@ typedef struct ProcedureMethod { * body bytecodes. */ int flags; /* Flags to control features. */ int refCount; - ClientData clientData; + void *clientData; TclOO_PmCDDeleteProc *deleteClientdataProc; TclOO_PmCDCloneProc *cloneClientdataProc; ProcErrorProc *errProc; /* Replacement error handler. */ @@ -368,7 +368,7 @@ typedef struct CallContext { #define PUBLIC_METHOD 0x01 /* This is a public (exported) method. */ #define PRIVATE_METHOD 0x02 /* This is a private (class's direct instances - * only) method. */ + * only) method. Supports itcl. */ #define OO_UNKNOWN_METHOD 0x04 /* This is an unknown method. */ #define CONSTRUCTOR 0x08 /* This is a constructor. */ #define DESTRUCTOR 0x10 /* This is a destructor. */ @@ -390,55 +390,55 @@ typedef struct { */ MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); -MODULE_SCOPE int TclOODefineObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOObjDefObjCmd(ClientData clientData, +MODULE_SCOPE int TclOOObjDefObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineConstructorObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineDestructorObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineDestructorObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineExportObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineExportObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineForwardObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineForwardObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineMethodObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineMethodObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineRenameMethodObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineRenameMethodObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineUnexportObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineUnexportObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineClassObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineSelfObjCmd(ClientData clientData, +MODULE_SCOPE int TclOODefineSelfObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOUnknownDefinition(ClientData clientData, +MODULE_SCOPE int TclOOUnknownDefinition(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOCopyObjectCmd(ClientData clientData, +MODULE_SCOPE int TclOOCopyObjectCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOONextObjCmd(ClientData clientData, +MODULE_SCOPE int TclOONextObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOONextToObjCmd(ClientData clientData, +MODULE_SCOPE int TclOONextToObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData, +MODULE_SCOPE int TclOOSelfObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); @@ -446,31 +446,31 @@ MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData, * Method implementations (in tclOOBasic.c). */ -MODULE_SCOPE int TclOO_Class_Constructor(ClientData clientData, +MODULE_SCOPE int TclOO_Class_Constructor(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Class_Create(ClientData clientData, +MODULE_SCOPE int TclOO_Class_Create(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Class_CreateNs(ClientData clientData, +MODULE_SCOPE int TclOO_Class_CreateNs(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Class_New(ClientData clientData, +MODULE_SCOPE int TclOO_Class_New(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_Destroy(ClientData clientData, +MODULE_SCOPE int TclOO_Object_Destroy(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_Eval(ClientData clientData, +MODULE_SCOPE int TclOO_Object_Eval(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_LinkVar(ClientData clientData, +MODULE_SCOPE int TclOO_Object_LinkVar(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_Unknown(ClientData clientData, +MODULE_SCOPE int TclOO_Object_Unknown(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_VarName(ClientData clientData, +MODULE_SCOPE int TclOO_Object_VarName(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); @@ -517,7 +517,7 @@ MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, int flags, const char ***stringsPtr); MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp); -MODULE_SCOPE int TclOOInvokeContext(ClientData clientData, +MODULE_SCOPE int TclOOInvokeContext(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, -- cgit v0.12 From f8ed9f54314d3f2dc8fe1b157cc7358c9ed7b371 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 21 Aug 2022 20:53:08 +0000 Subject: More type-casts in tclOOMethod.c (backported from 8.7) --- generic/tclOOMethod.c | 131 ++++++++++++++++++++++++++------------------------ 1 file changed, 67 insertions(+), 64 deletions(-) diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 717aa09..c65003f 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -3,7 +3,7 @@ * * This file contains code to create and manage methods. * - * Copyright (c) 2005-2011 by Donal K. Fellows + * Copyright (c) 2005-2011 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -67,7 +67,7 @@ static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int toRewrite, int rewriteLength, Tcl_Obj *const *rewriteObjs, int *lengthPtr); -static int InvokeProcedureMethod(ClientData clientData, +static int InvokeProcedureMethod(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static Tcl_NRPostProc FinalizeForwardCall; @@ -77,22 +77,22 @@ static int PushMethodCallFrame(Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, PMFrameData *fdPtr); static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr); -static void DeleteProcedureMethod(ClientData clientData); +static void DeleteProcedureMethod(void *clientData); static int CloneProcedureMethod(Tcl_Interp *interp, - ClientData clientData, ClientData *newClientData); + void *clientData, void **newClientData); static void MethodErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void ConstructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void DestructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); -static Tcl_Obj * RenderDeclarerName(ClientData clientData); -static int InvokeForwardMethod(ClientData clientData, +static Tcl_Obj * RenderDeclarerName(void *clientData); +static int InvokeForwardMethod(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -static void DeleteForwardMethod(ClientData clientData); +static void DeleteForwardMethod(void *clientData); static int CloneForwardMethod(Tcl_Interp *interp, - ClientData clientData, ClientData *newClientData); + void *clientData, void **newClientData); static int ProcedureMethodVarResolver(Tcl_Interp *interp, const char *varName, Tcl_Namespace *contextNs, int flags, Tcl_Var *varPtr); @@ -146,7 +146,7 @@ Tcl_NewInstanceMethod( /* The type of method this is, which defines * how to invoke, delete and clone the * method. */ - ClientData clientData) /* Some data associated with the particular + void *clientData) /* Some data associated with the particular * method to be created. */ { Object *oPtr = (Object *) object; @@ -155,25 +155,25 @@ Tcl_NewInstanceMethod( int isNew; if (nameObj == NULL) { - mPtr = ckalloc(sizeof(Method)); + mPtr = (Method *)ckalloc(sizeof(Method)); mPtr->namePtr = NULL; mPtr->refCount = 1; goto populate; } if (!oPtr->methodsPtr) { - oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable)); + oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->methodsPtr); oPtr->flags &= ~USE_CLASS_CACHE; } hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) nameObj, &isNew); if (isNew) { - mPtr = ckalloc(sizeof(Method)); + mPtr = (Method *)ckalloc(sizeof(Method)); mPtr->namePtr = nameObj; mPtr->refCount = 1; Tcl_IncrRefCount(nameObj); Tcl_SetHashValue(hPtr, mPtr); } else { - mPtr = Tcl_GetHashValue(hPtr); + mPtr = (Method *)Tcl_GetHashValue(hPtr); if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) { mPtr->typePtr->deleteProc(mPtr->clientData); } @@ -214,7 +214,7 @@ Tcl_NewMethod( /* The type of method this is, which defines * how to invoke, delete and clone the * method. */ - ClientData clientData) /* Some data associated with the particular + void *clientData) /* Some data associated with the particular * method to be created. */ { Class *clsPtr = (Class *) cls; @@ -223,20 +223,20 @@ Tcl_NewMethod( int isNew; if (nameObj == NULL) { - mPtr = ckalloc(sizeof(Method)); + mPtr = (Method *)ckalloc(sizeof(Method)); mPtr->namePtr = NULL; mPtr->refCount = 1; goto populate; } hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew); if (isNew) { - mPtr = ckalloc(sizeof(Method)); + mPtr = (Method *)ckalloc(sizeof(Method)); mPtr->refCount = 1; mPtr->namePtr = nameObj; Tcl_IncrRefCount(nameObj); Tcl_SetHashValue(hPtr, mPtr); } else { - mPtr = Tcl_GetHashValue(hPtr); + mPtr = (Method *)Tcl_GetHashValue(hPtr); if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) { mPtr->typePtr->deleteProc(mPtr->clientData); } @@ -342,7 +342,7 @@ TclOONewProcInstanceMethod( if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } - pmPtr = ckalloc(sizeof(ProcedureMethod)); + pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); memset(pmPtr, 0, sizeof(ProcedureMethod)); pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; pmPtr->flags = flags & USE_DECLARER_NS; @@ -403,7 +403,7 @@ TclOONewProcMethod( procName = (nameObj==NULL ? "" : TclGetString(nameObj)); } - pmPtr = ckalloc(sizeof(ProcedureMethod)); + pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); memset(pmPtr, 0, sizeof(ProcedureMethod)); pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; pmPtr->flags = flags & USE_DECLARER_NS; @@ -450,7 +450,7 @@ TclOOMakeProcInstanceMethod( * NULL. */ const Tcl_MethodType *typePtr, /* The type of the method to create. */ - ClientData clientData, /* The per-method type-specific data. */ + void *clientData, /* The per-method type-specific data. */ Proc **procPtrPtr) /* A pointer to the variable in which to write * the procedure record reference. Presumably * inside the structure indicated by the @@ -497,12 +497,12 @@ TclOOMakeProcInstanceMethod( if (context.line && (context.nline >= 4) && (context.line[3] >= 0)) { int isNew; - CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame)); + CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); Tcl_HashEntry *hPtr; cfPtr->level = -1; cfPtr->type = context.type; - cfPtr->line = ckalloc(sizeof(int)); + cfPtr->line = (int *)ckalloc(sizeof(int)); cfPtr->line[0] = context.line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -563,7 +563,7 @@ TclOOMakeProcMethod( * NULL. */ const Tcl_MethodType *typePtr, /* The type of the method to create. */ - ClientData clientData, /* The per-method type-specific data. */ + void *clientData, /* The per-method type-specific data. */ Proc **procPtrPtr) /* A pointer to the variable in which to write * the procedure record reference. Presumably * inside the structure indicated by the @@ -610,12 +610,12 @@ TclOOMakeProcMethod( if (context.line && (context.nline >= 4) && (context.line[3] >= 0)) { int isNew; - CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame)); + CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); Tcl_HashEntry *hPtr; cfPtr->level = -1; cfPtr->type = context.type; - cfPtr->line = ckalloc(sizeof(int)); + cfPtr->line = (int *)ckalloc(sizeof(int)); cfPtr->line[0] = context.line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -658,13 +658,13 @@ TclOOMakeProcMethod( static int InvokeProcedureMethod( - ClientData clientData, /* Pointer to some per-method context. */ + void *clientData, /* Pointer to some per-method context. */ Tcl_Interp *interp, Tcl_ObjectContext context, /* The method calling context. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments as actually seen. */ { - ProcedureMethod *pmPtr = clientData; + ProcedureMethod *pmPtr = (ProcedureMethod *)clientData; int result; PMFrameData *fdPtr; /* Important data that has to have a lifetime * matched by this function (or rather, by the @@ -686,7 +686,7 @@ InvokeProcedureMethod( * Allocate the special frame data. */ - fdPtr = TclStackAlloc(interp, sizeof(PMFrameData)); + fdPtr = (PMFrameData *)TclStackAlloc(interp, sizeof(PMFrameData)); /* * Create a call frame for this method. @@ -739,13 +739,13 @@ InvokeProcedureMethod( static int FinalizePMCall( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { - ProcedureMethod *pmPtr = data[0]; - Tcl_ObjectContext context = data[1]; - PMFrameData *fdPtr = data[2]; + ProcedureMethod *pmPtr = (ProcedureMethod *)data[0]; + Tcl_ObjectContext context = (Tcl_ObjectContext)data[1]; + PMFrameData *fdPtr = (PMFrameData *)data[2]; /* * Give the post-call callback a chance to do some cleanup. Note that at @@ -999,7 +999,7 @@ ProcedureMethodCompiledVarConnect( if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { return NULL; } - contextPtr = framePtr->clientData; + contextPtr = (CallContext *)framePtr->clientData; /* * If we've done the work before (in a comparable context) then reuse that @@ -1102,7 +1102,7 @@ ProcedureMethodCompiledVarResolver( return TCL_CONTINUE; } - infoPtr = ckalloc(sizeof(OOResVarInfo)); + infoPtr = (OOResVarInfo *)ckalloc(sizeof(OOResVarInfo)); infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect; infoPtr->info.deleteProc = ProcedureMethodCompiledVarDelete; infoPtr->cachedObjectVar = NULL; @@ -1127,9 +1127,9 @@ ProcedureMethodCompiledVarResolver( static Tcl_Obj * RenderDeclarerName( - ClientData clientData) + void *clientData) { - struct PNI *pni = clientData; + struct PNI *pni = (struct PNI *)clientData; Tcl_Object object = Tcl_MethodDeclarerObject(pni->method); if (object == NULL) { @@ -1163,11 +1163,12 @@ MethodErrorHandler( Tcl_Obj *methodNameObj) { int nameLen, objectNameLen; - CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData; + CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData; Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; const char *objectName, *kindName, *methodName = Tcl_GetStringFromObj(mPtr->namePtr, &nameLen); Object *declarerPtr; + (void)methodNameObj;/* We pull the method name out of context instead of from argument */ if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; @@ -1193,11 +1194,12 @@ ConstructorErrorHandler( Tcl_Interp *interp, Tcl_Obj *methodNameObj) { - CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData; + CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData; Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; Object *declarerPtr; const char *objectName, *kindName; int objectNameLen; + (void)methodNameObj;/* Ignore. We know it is the constructor. */ if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; @@ -1222,11 +1224,12 @@ DestructorErrorHandler( Tcl_Interp *interp, Tcl_Obj *methodNameObj) { - CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData; + CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData; Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; Object *declarerPtr; const char *objectName, *kindName; int objectNameLen; + (void)methodNameObj; /* Ignore. We know it is the destructor. */ if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; @@ -1269,9 +1272,9 @@ DeleteProcedureMethodRecord( static void DeleteProcedureMethod( - ClientData clientData) + void *clientData) { - ProcedureMethod *pmPtr = clientData; + ProcedureMethod *pmPtr = (ProcedureMethod *)clientData; if (pmPtr->refCount-- <= 1) { DeleteProcedureMethodRecord(pmPtr); @@ -1281,10 +1284,10 @@ DeleteProcedureMethod( static int CloneProcedureMethod( Tcl_Interp *interp, - ClientData clientData, - ClientData *newClientData) + void *clientData, + void **newClientData) { - ProcedureMethod *pmPtr = clientData; + ProcedureMethod *pmPtr = (ProcedureMethod *)clientData; ProcedureMethod *pm2Ptr; Tcl_Obj *bodyObj, *argsObj; CompiledLocal *localPtr; @@ -1323,7 +1326,7 @@ CloneProcedureMethod( * record. */ - pm2Ptr = ckalloc(sizeof(ProcedureMethod)); + pm2Ptr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; Tcl_IncrRefCount(argsObj); @@ -1377,7 +1380,7 @@ TclOONewForwardInstanceMethod( return NULL; } - fmPtr = ckalloc(sizeof(ForwardMethod)); + fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, @@ -1416,7 +1419,7 @@ TclOONewForwardMethod( return NULL; } - fmPtr = ckalloc(sizeof(ForwardMethod)); + fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, @@ -1436,14 +1439,14 @@ TclOONewForwardMethod( static int InvokeForwardMethod( - ClientData clientData, /* Pointer to some per-method context. */ + void *clientData, /* Pointer to some per-method context. */ Tcl_Interp *interp, Tcl_ObjectContext context, /* The method calling context. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments as actually seen. */ { CallContext *contextPtr = (CallContext *) context; - ForwardMethod *fmPtr = clientData; + ForwardMethod *fmPtr = (ForwardMethod *)clientData; Tcl_Obj **argObjs, **prefixObjs; int numPrefixes, len, skip = contextPtr->skip; @@ -1470,11 +1473,11 @@ InvokeForwardMethod( static int FinalizeForwardCall( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { - Tcl_Obj **argObjs = data[0]; + Tcl_Obj **argObjs = (Tcl_Obj **)data[0]; TclStackFree(interp, argObjs); return result; @@ -1492,9 +1495,9 @@ FinalizeForwardCall( static void DeleteForwardMethod( - ClientData clientData) + void *clientData) { - ForwardMethod *fmPtr = clientData; + ForwardMethod *fmPtr = (ForwardMethod *)clientData; Tcl_DecrRefCount(fmPtr->prefixObj); ckfree(fmPtr); @@ -1503,11 +1506,11 @@ DeleteForwardMethod( static int CloneForwardMethod( Tcl_Interp *interp, - ClientData clientData, - ClientData *newClientData) + void *clientData, + void **newClientData) { - ForwardMethod *fmPtr = clientData; - ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod)); + ForwardMethod *fmPtr = (ForwardMethod *)clientData; + ForwardMethod *fm2Ptr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod)); fm2Ptr->prefixObj = fmPtr->prefixObj; Tcl_IncrRefCount(fm2Ptr->prefixObj); @@ -1531,7 +1534,7 @@ TclOOGetProcFromMethod( Method *mPtr) { if (mPtr->typePtr == &procMethodType) { - ProcedureMethod *pmPtr = mPtr->clientData; + ProcedureMethod *pmPtr = (ProcedureMethod *)mPtr->clientData; return pmPtr->procPtr; } @@ -1543,7 +1546,7 @@ TclOOGetMethodBody( Method *mPtr) { if (mPtr->typePtr == &procMethodType) { - ProcedureMethod *pmPtr = mPtr->clientData; + ProcedureMethod *pmPtr = (ProcedureMethod *)mPtr->clientData; if (pmPtr->procPtr->bodyPtr->bytes == NULL) { (void) Tcl_GetString(pmPtr->procPtr->bodyPtr); @@ -1558,7 +1561,7 @@ TclOOGetFwdFromMethod( Method *mPtr) { if (mPtr->typePtr == &fwdMethodType) { - ForwardMethod *fwPtr = mPtr->clientData; + ForwardMethod *fwPtr = (ForwardMethod *)mPtr->clientData; return fwPtr->prefixObj; } @@ -1600,7 +1603,7 @@ InitEnsembleRewrite( * array of rewritten arguments. */ { unsigned len = rewriteLength + objc - toRewrite; - Tcl_Obj **argObjs = TclStackAlloc(interp, sizeof(Tcl_Obj *) * len); + Tcl_Obj **argObjs = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * len); memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *)); memcpy(argObjs + rewriteLength, objv + toRewrite, @@ -1655,7 +1658,7 @@ int Tcl_MethodIsType( Tcl_Method method, const Tcl_MethodType *typePtr, - ClientData *clientDataPtr) + void **clientDataPtr) { Method *mPtr = (Method *) method; @@ -1686,7 +1689,7 @@ TclOONewProcInstanceMethodEx( TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, - ClientData clientData, + void *clientData, Tcl_Obj *nameObj, /* The name of the method, which must not be * NULL. */ Tcl_Obj *argsObj, /* The formal argument list for the method, @@ -1723,7 +1726,7 @@ TclOONewProcMethodEx( TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, - ClientData clientData, + void *clientData, Tcl_Obj *nameObj, /* The name of the method, which may be NULL; * if so, up to caller to manage storage * (e.g., because it is a constructor or -- cgit v0.12 From e45303142daf39e0a1d4f7e0056c02fcbb3fff5f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 21 Aug 2022 21:00:30 +0000 Subject: Add (dummy) stub entries to TclOO (matching TIP #630) --- generic/tclOO.decls | 24 ++++++++++++------------ generic/tclOODecls.h | 43 ++++++++++++++++++++++++++----------------- generic/tclOOIntDecls.h | 28 ++++++++++++++-------------- generic/tclOOStubInit.c | 5 ++++- 4 files changed, 56 insertions(+), 44 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 8a4fd1e..67b1996 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -51,7 +51,7 @@ declare 8 { } declare 9 { int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, - ClientData *clientDataPtr) + void **clientDataPtr) } declare 10 { Tcl_Obj *Tcl_MethodName(Tcl_Method method) @@ -59,12 +59,12 @@ declare 10 { declare 11 { Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, - ClientData clientData) + void *clientData) } declare 12 { Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, - ClientData clientData) + void *clientData) } declare 13 { Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, @@ -87,20 +87,20 @@ declare 18 { int Tcl_ObjectContextSkippedArgs(Tcl_ObjectContext context) } declare 19 { - ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, + void *Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr) } declare 20 { void Tcl_ClassSetMetadata(Tcl_Class clazz, - const Tcl_ObjectMetadataType *typePtr, ClientData metadata) + const Tcl_ObjectMetadataType *typePtr, void *metadata) } declare 21 { - ClientData Tcl_ObjectGetMetadata(Tcl_Object object, + void *Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr) } declare 22 { void Tcl_ObjectSetMetadata(Tcl_Object object, - const Tcl_ObjectMetadataType *typePtr, ClientData metadata) + const Tcl_ObjectMetadataType *typePtr, void *metadata) } declare 23 { int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, @@ -126,7 +126,7 @@ declare 27 { declare 28 { Tcl_Obj *Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object) } -declare 31 { +declare 34 { void TclOOUnusedStubEntry(void) } @@ -144,14 +144,14 @@ declare 0 { declare 1 { Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, - const Tcl_MethodType *typePtr, ClientData clientData, + const Tcl_MethodType *typePtr, void *clientData, Proc **procPtrPtr) } declare 2 { Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, - ClientData clientData, Proc **procPtrPtr) + void *clientData, Proc **procPtrPtr) } declare 3 { Method *TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, @@ -182,13 +182,13 @@ declare 9 { Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, - ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, + void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr) } declare 10 { Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, - ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj, + ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr) } diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index ead34f7..647bbd5 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -53,19 +53,19 @@ TCLAPI int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ TCLAPI int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, - ClientData *clientDataPtr); + void **clientDataPtr); /* 10 */ TCLAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ TCLAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, - ClientData clientData); + void *clientData); /* 12 */ TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, - ClientData clientData); + void *clientData); /* 13 */ TCLAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, @@ -84,19 +84,19 @@ TCLAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); TCLAPI int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ -TCLAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, +TCLAPI void * Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ TCLAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, - ClientData metadata); + void *metadata); /* 21 */ -TCLAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, +TCLAPI void * Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ TCLAPI void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, - ClientData metadata); + void *metadata); /* 23 */ TCLAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -118,7 +118,10 @@ TCLAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); /* Slot 29 is reserved */ /* Slot 30 is reserved */ -/* 31 */ +/* Slot 31 is reserved */ +/* Slot 32 is reserved */ +/* Slot 33 is reserved */ +/* 34 */ TCLAPI void TclOOUnusedStubEntry(void); typedef struct { @@ -138,20 +141,20 @@ typedef struct TclOOStubs { Tcl_Class (*tcl_MethodDeclarerClass) (Tcl_Method method); /* 6 */ Tcl_Object (*tcl_MethodDeclarerObject) (Tcl_Method method); /* 7 */ int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */ - int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 9 */ + int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, void **clientDataPtr); /* 9 */ Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */ - Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */ - Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ + Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, void *clientData); /* 11 */ + Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, void *clientData); /* 12 */ Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 13 */ int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */ int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */ Tcl_Method (*tcl_ObjectContextMethod) (Tcl_ObjectContext context); /* 16 */ Tcl_Object (*tcl_ObjectContextObject) (Tcl_ObjectContext context); /* 17 */ int (*tcl_ObjectContextSkippedArgs) (Tcl_ObjectContext context); /* 18 */ - ClientData (*tcl_ClassGetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 19 */ - void (*tcl_ClassSetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 20 */ - ClientData (*tcl_ObjectGetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 21 */ - void (*tcl_ObjectSetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 22 */ + void * (*tcl_ClassGetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 19 */ + void (*tcl_ClassSetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, void *metadata); /* 20 */ + void * (*tcl_ObjectGetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 21 */ + void (*tcl_ObjectSetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, void *metadata); /* 22 */ int (*tcl_ObjectContextInvokeNext) (Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 23 */ Tcl_ObjectMapMethodNameProc * (*tcl_ObjectGetMethodNameMapper) (Tcl_Object object); /* 24 */ void (*tcl_ObjectSetMethodNameMapper) (Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 25 */ @@ -160,7 +163,10 @@ typedef struct TclOOStubs { Tcl_Obj * (*tcl_GetObjectName) (Tcl_Interp *interp, Tcl_Object object); /* 28 */ void (*reserved29)(void); void (*reserved30)(void); - void (*tclOOUnusedStubEntry) (void); /* 31 */ + void (*reserved31)(void); + void (*reserved32)(void); + void (*reserved33)(void); + void (*tclOOUnusedStubEntry) (void); /* 34 */ } TclOOStubs; extern const TclOOStubs *tclOOStubsPtr; @@ -235,8 +241,11 @@ extern const TclOOStubs *tclOOStubsPtr; (tclOOStubsPtr->tcl_GetObjectName) /* 28 */ /* Slot 29 is reserved */ /* Slot 30 is reserved */ +/* Slot 31 is reserved */ +/* Slot 32 is reserved */ +/* Slot 33 is reserved */ #define TclOOUnusedStubEntry \ - (tclOOStubsPtr->tclOOUnusedStubEntry) /* 31 */ + (tclOOStubsPtr->tclOOUnusedStubEntry) /* 34 */ #endif /* defined(USE_TCLOO_STUBS) */ diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index 74a8d81..6a5cfd3 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -22,14 +22,14 @@ TCLAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, - ClientData clientData, Proc **procPtrPtr); + void *clientData, Proc **procPtrPtr); /* 2 */ TCLAPI Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, - ClientData clientData, Proc **procPtrPtr); + void *clientData, Proc **procPtrPtr); /* 3 */ TCLAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, @@ -59,19 +59,19 @@ TCLAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, - ProcErrorProc *errProc, - ClientData clientData, Tcl_Obj *nameObj, - Tcl_Obj *argsObj, Tcl_Obj *bodyObj, - int flags, void **internalTokenPtr); + ProcErrorProc *errProc, void *clientData, + Tcl_Obj *nameObj, Tcl_Obj *argsObj, + Tcl_Obj *bodyObj, int flags, + void **internalTokenPtr); /* 10 */ TCLAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, - ProcErrorProc *errProc, - ClientData clientData, Tcl_Obj *nameObj, - Tcl_Obj *argsObj, Tcl_Obj *bodyObj, - int flags, void **internalTokenPtr); + ProcErrorProc *errProc, void *clientData, + Tcl_Obj *nameObj, Tcl_Obj *argsObj, + Tcl_Obj *bodyObj, int flags, + void **internalTokenPtr); /* 11 */ TCLAPI int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, @@ -97,16 +97,16 @@ typedef struct TclOOIntStubs { void *hooks; Tcl_Object (*tclOOGetDefineCmdContext) (Tcl_Interp *interp); /* 0 */ - Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 1 */ - Tcl_Method (*tclOOMakeProcMethod) (Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 2 */ + Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, void *clientData, Proc **procPtrPtr); /* 1 */ + Tcl_Method (*tclOOMakeProcMethod) (Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, void *clientData, Proc **procPtrPtr); /* 2 */ Method * (*tclOONewProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 3 */ Method * (*tclOONewProcMethod) (Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */ int (*tclOOObjectCmdCore) (Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 5 */ int (*tclOOIsReachable) (Class *targetPtr, Class *startPtr); /* 6 */ Method * (*tclOONewForwardMethod) (Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 7 */ Method * (*tclOONewForwardInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */ - Tcl_Method (*tclOONewProcInstanceMethodEx) (Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 9 */ - Tcl_Method (*tclOONewProcMethodEx) (Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ + Tcl_Method (*tclOONewProcInstanceMethodEx) (Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 9 */ + Tcl_Method (*tclOONewProcMethodEx) (Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ int (*tclOOInvokeObject) (Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 11 */ void (*tclOOObjectSetFilters) (Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 12 */ void (*tclOOClassSetFilters) (Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */ diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c index e8534eb..735d871 100644 --- a/generic/tclOOStubInit.c +++ b/generic/tclOOStubInit.c @@ -77,7 +77,10 @@ const TclOOStubs tclOOStubs = { Tcl_GetObjectName, /* 28 */ 0, /* 29 */ 0, /* 30 */ - TclOOUnusedStubEntry, /* 31 */ + 0, /* 31 */ + 0, /* 32 */ + 0, /* 33 */ + TclOOUnusedStubEntry, /* 34 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12