From 82d5e7d59540bfd95e3258032a92d4607752d9cd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 15 Aug 2021 20:35:59 +0000 Subject: Proposed TIP #609 implementation --- doc/Notifier.3 | 23 ++++++++++++++++++----- generic/tcl.h | 17 +++++++++++++++++ generic/tclIORChan.c | 8 ++++---- generic/tclIORTrans.c | 4 ++-- generic/tclNotify.c | 35 ++++++++++++++++++++++++----------- generic/tclThreadTest.c | 3 +-- 6 files changed, 66 insertions(+), 24 deletions(-) diff --git a/doc/Notifier.3 b/doc/Notifier.3 index ec9f910..755930f 100644 --- a/doc/Notifier.3 +++ b/doc/Notifier.3 @@ -92,7 +92,9 @@ 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 Tcl_QueuePosition position in Where to add the new event in the queue: \fBTCL_QUEUE_TAIL\fR, -\fBTCL_QUEUE_HEAD\fR, or \fBTCL_QUEUE_MARK\fR. +\fBTCL_QUEUE_HEAD\fR, \fBTCL_QUEUE_MARK\fR, +\fBTCL_QUEUE_TAIL_ALERT_IF_EMPTY\fR, or +\fBTCL_QUEUE_HEAD_ALERT_IF_EMPTY\fR. .AP Tcl_ThreadId threadId in A unique identifier for a thread. .AP Tcl_EventDeleteProc *deleteProc in @@ -340,14 +342,14 @@ and should not be modified by the event source. .PP An event may be added to the queue at any of three positions, depending on the \fIposition\fR argument to \fBTcl_QueueEvent\fR: -.IP \fBTCL_QUEUE_TAIL\fR 24 +.IP \fBTCL_QUEUE_TAIL\fR 32 Add the event at the back of the queue, so that all other pending events will be serviced first. This is almost always the right place for new events. -.IP \fBTCL_QUEUE_HEAD\fR 24 +.IP \fBTCL_QUEUE_HEAD\fR 32 Add the event at the front of the queue, so that it will be serviced before all other queued events. -.IP \fBTCL_QUEUE_MARK\fR 24 +.IP \fBTCL_QUEUE_MARK\fR 32 Add the event at the front of the queue, unless there are other events at the front whose position is \fBTCL_QUEUE_MARK\fR; if so, add the new event just after all other \fBTCL_QUEUE_MARK\fR events. @@ -355,6 +357,14 @@ This value of \fIposition\fR is used to insert an ordered sequence of events at the front of the queue, such as a series of Enter and Leave events synthesized during a grab or ungrab operation in Tk. +.IP \fBTCL_QUEUE_TAIL_ALERT_IF_EMPTY\fR 32 +Like \fBTCL_QUEUE_TAIL\fR but when used in \fBTcl_ThreadQueueEvent\fR +arranges for an automatic call of \fBTcl_ThreadAlert\fR when the queue was +empty. +.IP \fBTCL_QUEUE_HEAD_ALERT_IF_EMPTY\fR 32 +Like \fBTCL_QUEUE_HEAD\fR but when used in \fBTcl_ThreadQueueEvent\fR +arranges for an automatic call of \fBTcl_ThreadAlert\fR when the queue was +empty. .PP When it is time to handle an event from the queue (steps 1 and 4 above) \fBTcl_ServiceEvent\fR will invoke the \fIproc\fR specified @@ -408,7 +418,10 @@ threads for those threads to be able to add events to its queue.) After adding an event to another thread's queue, you then typically need to call \fBTcl_ThreadAlert\fR to .QW "wake up" -that thread's notifier to alert it to the new event. +that thread's notifier to alert it to the new event. Alternatively, +the queue positions \fBTCL_QUEUE_TAIL_ALERT_IF_EMPTY\fR and +\fBTCL_QUEUE_HEAD_ALERT_IF_EMPTY\fR can be used which automatically +call \fBTcl_ThreadAlert\fR if the thread's queue was empty. .PP \fBTcl_DeleteEvents\fR can be used to explicitly remove one or more events from the event queue. \fBTcl_DeleteEvents\fR calls \fIproc\fR diff --git a/generic/tcl.h b/generic/tcl.h index 2d529b7..1ce68b4 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1337,6 +1337,23 @@ typedef enum { } Tcl_QueuePosition; /* + * Positions for Tcl_ThreadQueueEvent: + */ + +typedef enum { + TCL_QUEUE_TAIL_EX = TCL_QUEUE_TAIL, + TCL_QUEUE_HEAD_EX = TCL_QUEUE_HEAD, + TCL_QUEUE_MARK_EX = TCL_QUEUE_MARK, + TCL_QUEUE_TAIL_EX_ALERT_IF_EMPTY, + TCL_QUEUE_HEAD_EX_ALERT_IF_EMPTY, +} Tcl_QueuePositionEx; + +#define TCL_QUEUE_TAIL_ALERT_IF_EMPTY \ + ((Tcl_QueuePosition) TCL_QUEUE_TAIL_EX_ALERT_IF_EMPTY) +#define TCL_QUEUE_HEAD_ALERT_IF_EMPTY \ + ((Tcl_QueuePosition) TCL_QUEUE_HEAD_EX_ALERT_IF_EMPTY) + +/* * Values to pass to Tcl_SetServiceMode to specify the behavior of notifier * event routines. */ diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index cc45873..b473417 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -994,8 +994,8 @@ TclChanPostEventObjCmd( * XXX Actually, in that case the channel should be dead also ! */ - Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev, TCL_QUEUE_TAIL); - Tcl_ThreadAlert(rcPtr->owner); + Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev, + TCL_QUEUE_TAIL_ALERT_IF_EMPTY); } #endif @@ -2996,8 +2996,8 @@ ForwardOpToHandlerThread( * Queue the event and poke the other thread's notifier. */ - Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, TCL_QUEUE_TAIL); - Tcl_ThreadAlert(dst); + Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, + TCL_QUEUE_TAIL_ALERT_IF_EMPTY); /* * (*) Block until the handler thread has either processed the transfer or diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index b06bd45..eda72ba 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -2452,8 +2452,8 @@ ForwardOpToOwnerThread( * Queue the event and poke the other thread's notifier. */ - Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, TCL_QUEUE_TAIL); - Tcl_ThreadAlert(dst); + Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, + TCL_QUEUE_TAIL_ALERT_IF_EMPTY); /* * (*) Block until the other thread has either processed the transfer or diff --git a/generic/tclNotify.c b/generic/tclNotify.c index 12b40b1..99aceec 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -95,8 +95,8 @@ TCL_DECLARE_MUTEX(listLock) * Declarations for routines used only in this file. */ -static void QueueEvent(ThreadSpecificData *tsdPtr, - Tcl_Event *evPtr, Tcl_QueuePosition position); +static int QueueEvent(ThreadSpecificData *tsdPtr, + Tcl_Event *evPtr, Tcl_QueuePositionEx position); /* *---------------------------------------------------------------------- @@ -397,7 +397,7 @@ Tcl_QueueEvent( { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - QueueEvent(tsdPtr, evPtr, position); + (void) QueueEvent(tsdPtr, evPtr, (Tcl_QueuePositionEx) position); } /* @@ -444,7 +444,9 @@ Tcl_ThreadQueueEvent( */ if (tsdPtr) { - QueueEvent(tsdPtr, evPtr, position); + if (QueueEvent(tsdPtr, evPtr, (Tcl_QueuePositionEx) position)) { + Tcl_AlertNotifier(tsdPtr->clientData); + } } else { ckfree(evPtr); } @@ -464,7 +466,8 @@ Tcl_ThreadQueueEvent( * last-in-first-out order. * * Results: - * None. + * For TCL_QUEUE_(HEAD|TAIL)_ALERT_IF_EMPTY the empty state before the + * operation is returned. * * Side effects: * None. @@ -472,7 +475,7 @@ Tcl_ThreadQueueEvent( *---------------------------------------------------------------------- */ -static void +static int QueueEvent( ThreadSpecificData *tsdPtr, /* Handle to thread local data that indicates * which event queue to use. */ @@ -481,11 +484,17 @@ QueueEvent( * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, - * TCL_QUEUE_MARK. */ + Tcl_QueuePositionEx position) + /* One of TCL_QUEUE_TAIL_EX, + * TCL_QUEUE_HEAD_EX, TCL_QUEUE_MARK_EX, + * TCL_QUEUE_TAIL_ALERT_IF_EMPTY, or + * TCL_QUEUE_HEAD_ALERT_IF_EMPTY. */ { + int wasEmpty = 0; + Tcl_MutexLock(&(tsdPtr->queueMutex)); - if (position == TCL_QUEUE_TAIL) { + if ((position == TCL_QUEUE_TAIL_EX) || + (position == TCL_QUEUE_TAIL_EX_ALERT_IF_EMPTY)) { /* * Append the event on the end of the queue. */ @@ -493,11 +502,13 @@ QueueEvent( evPtr->nextPtr = NULL; if (tsdPtr->firstEventPtr == NULL) { tsdPtr->firstEventPtr = evPtr; + wasEmpty = (position == TCL_QUEUE_TAIL_EX_ALERT_IF_EMPTY) ? 1 : 0; } else { tsdPtr->lastEventPtr->nextPtr = evPtr; } tsdPtr->lastEventPtr = evPtr; - } else if (position == TCL_QUEUE_HEAD) { + } else if ((position == TCL_QUEUE_HEAD_EX) || + (position == TCL_QUEUE_HEAD_EX_ALERT_IF_EMPTY)) { /* * Push the event on the head of the queue. */ @@ -505,9 +516,10 @@ QueueEvent( evPtr->nextPtr = tsdPtr->firstEventPtr; if (tsdPtr->firstEventPtr == NULL) { tsdPtr->lastEventPtr = evPtr; + wasEmpty = (position == TCL_QUEUE_HEAD_EX_ALERT_IF_EMPTY) ? 1 : 0; } tsdPtr->firstEventPtr = evPtr; - } else if (position == TCL_QUEUE_MARK) { + } else if (position == TCL_QUEUE_MARK_EX) { /* * Insert the event after the current marker event and advance the * marker to the new event. @@ -526,6 +538,7 @@ QueueEvent( } } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); + return wasEmpty; } /* diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 9f08d83..887f645 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -878,8 +878,7 @@ ThreadSend( threadEventPtr->event.proc = ThreadEventProc; Tcl_ThreadQueueEvent(threadId, (Tcl_Event *) threadEventPtr, - TCL_QUEUE_TAIL); - Tcl_ThreadAlert(threadId); + TCL_QUEUE_TAIL_ALERT_IF_EMPTY); if (!wait) { Tcl_MutexUnlock(&threadMutex); -- cgit v0.12 From 31b544baefc9bf84fded3c7dfb98da9db1032e10 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 15 Aug 2021 21:34:02 +0000 Subject: Make TCL_QUEUE_ALERT_IF_EMPTY a separate flag --- doc/Notifier.3 | 15 +++++---------- generic/tcl.decls | 4 ++-- generic/tcl.h | 22 +++------------------- generic/tclDecls.h | 9 ++++----- generic/tclIORChan.c | 4 ++-- generic/tclIORTrans.c | 2 +- generic/tclNotify.c | 33 +++++++++++++++------------------ generic/tclTest.c | 2 +- generic/tclThreadTest.c | 2 +- 9 files changed, 34 insertions(+), 59 deletions(-) diff --git a/doc/Notifier.3 b/doc/Notifier.3 index 755930f..3fb13a2 100644 --- a/doc/Notifier.3 +++ b/doc/Notifier.3 @@ -90,11 +90,10 @@ 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 Tcl_QueuePosition position in +.AP int flags in Where to add the new event in the queue: \fBTCL_QUEUE_TAIL\fR, -\fBTCL_QUEUE_HEAD\fR, \fBTCL_QUEUE_MARK\fR, -\fBTCL_QUEUE_TAIL_ALERT_IF_EMPTY\fR, or -\fBTCL_QUEUE_HEAD_ALERT_IF_EMPTY\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. .AP Tcl_ThreadId threadId in A unique identifier for a thread. .AP Tcl_EventDeleteProc *deleteProc in @@ -357,12 +356,8 @@ This value of \fIposition\fR is used to insert an ordered sequence of events at the front of the queue, such as a series of Enter and Leave events synthesized during a grab or ungrab operation in Tk. -.IP \fBTCL_QUEUE_TAIL_ALERT_IF_EMPTY\fR 32 -Like \fBTCL_QUEUE_TAIL\fR but when used in \fBTcl_ThreadQueueEvent\fR -arranges for an automatic call of \fBTcl_ThreadAlert\fR when the queue was -empty. -.IP \fBTCL_QUEUE_HEAD_ALERT_IF_EMPTY\fR 32 -Like \fBTCL_QUEUE_HEAD\fR but when used in \fBTcl_ThreadQueueEvent\fR +.IP \fBTCL_QUEUE_ALERT_IF_EMPTY\fR 32 +When used in \fBTcl_ThreadQueueEvent\fR arranges for an automatic call of \fBTcl_ThreadAlert\fR when the queue was empty. .PP diff --git a/generic/tcl.decls b/generic/tcl.decls index 3dec972..a1bf91b 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -732,7 +732,7 @@ declare 204 { const char *Tcl_PosixError(Tcl_Interp *interp) } declare 205 { - void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position) + void Tcl_QueueEvent(Tcl_Event *evPtr, int flags) } declare 206 { int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead) @@ -1142,7 +1142,7 @@ declare 318 { } declare 319 { void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr, - Tcl_QueuePosition position) + int flags) } declare 320 { int Tcl_UniCharAtIndex(const char *src, int index) diff --git a/generic/tcl.h b/generic/tcl.h index 1ce68b4..4316f50 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1329,31 +1329,15 @@ struct Tcl_Event { }; /* - * Positions to pass to Tcl_QueueEvent: + * Positions to pass to Tcl_QueueEvent/Tcl_ThreadQueueEvent: */ typedef enum { - TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK + TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, + TCL_QUEUE_ALERT_IF_EMPTY=4 } Tcl_QueuePosition; /* - * Positions for Tcl_ThreadQueueEvent: - */ - -typedef enum { - TCL_QUEUE_TAIL_EX = TCL_QUEUE_TAIL, - TCL_QUEUE_HEAD_EX = TCL_QUEUE_HEAD, - TCL_QUEUE_MARK_EX = TCL_QUEUE_MARK, - TCL_QUEUE_TAIL_EX_ALERT_IF_EMPTY, - TCL_QUEUE_HEAD_EX_ALERT_IF_EMPTY, -} Tcl_QueuePositionEx; - -#define TCL_QUEUE_TAIL_ALERT_IF_EMPTY \ - ((Tcl_QueuePosition) TCL_QUEUE_TAIL_EX_ALERT_IF_EMPTY) -#define TCL_QUEUE_HEAD_ALERT_IF_EMPTY \ - ((Tcl_QueuePosition) TCL_QUEUE_HEAD_EX_ALERT_IF_EMPTY) - -/* * Values to pass to Tcl_SetServiceMode to specify the behavior of notifier * event routines. */ diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 713f3e9..fb22928 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -644,8 +644,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, - Tcl_QueuePosition position); +EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, int flags); /* 206 */ EXTERN int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead); /* 207 */ @@ -985,7 +984,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, Tcl_QueuePosition position); + Tcl_Event *evPtr, int flags); /* 320 */ EXTERN int Tcl_UniCharAtIndex(const char *src, int index); /* 321 */ @@ -2179,7 +2178,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, Tcl_QueuePosition position); /* 205 */ + void (*tcl_QueueEvent) (Tcl_Event *evPtr, int flags); /* 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 */ @@ -2293,7 +2292,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, Tcl_QueuePosition position); /* 319 */ + void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, int flags); /* 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/tclIORChan.c b/generic/tclIORChan.c index b473417..3f8a51e 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -995,7 +995,7 @@ TclChanPostEventObjCmd( */ Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev, - TCL_QUEUE_TAIL_ALERT_IF_EMPTY); + TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY); } #endif @@ -2997,7 +2997,7 @@ ForwardOpToHandlerThread( */ Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, - TCL_QUEUE_TAIL_ALERT_IF_EMPTY); + TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY); /* * (*) Block until the handler thread has either processed the transfer or diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index eda72ba..1d66835 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -2453,7 +2453,7 @@ ForwardOpToOwnerThread( */ Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, - TCL_QUEUE_TAIL_ALERT_IF_EMPTY); + TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY); /* * (*) Block until the other thread has either processed the transfer or diff --git a/generic/tclNotify.c b/generic/tclNotify.c index 99aceec..fa85f95 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, Tcl_QueuePositionEx position); + Tcl_Event *evPtr, int flags); /* *---------------------------------------------------------------------- @@ -392,12 +392,12 @@ Tcl_QueueEvent( * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, - * TCL_QUEUE_MARK. */ + int flags) /* 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, (Tcl_QueuePositionEx) position); + (void) QueueEvent(tsdPtr, evPtr, flags); } /* @@ -424,8 +424,8 @@ Tcl_ThreadQueueEvent( * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, - * TCL_QUEUE_MARK. */ + int flags) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, + * TCL_QUEUE_MARK, possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */ { ThreadSpecificData *tsdPtr; @@ -444,7 +444,7 @@ Tcl_ThreadQueueEvent( */ if (tsdPtr) { - if (QueueEvent(tsdPtr, evPtr, (Tcl_QueuePositionEx) position)) { + if (QueueEvent(tsdPtr, evPtr, flags)) { Tcl_AlertNotifier(tsdPtr->clientData); } } else { @@ -466,7 +466,7 @@ Tcl_ThreadQueueEvent( * last-in-first-out order. * * Results: - * For TCL_QUEUE_(HEAD|TAIL)_ALERT_IF_EMPTY the empty state before the + * For TCL_QUEUE_ALERT_IF_EMPTY the empty state before the * operation is returned. * * Side effects: @@ -484,17 +484,15 @@ QueueEvent( * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - Tcl_QueuePositionEx position) + int flags) /* One of TCL_QUEUE_TAIL_EX, * TCL_QUEUE_HEAD_EX, TCL_QUEUE_MARK_EX, - * TCL_QUEUE_TAIL_ALERT_IF_EMPTY, or - * TCL_QUEUE_HEAD_ALERT_IF_EMPTY. */ + * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY */ { int wasEmpty = 0; Tcl_MutexLock(&(tsdPtr->queueMutex)); - if ((position == TCL_QUEUE_TAIL_EX) || - (position == TCL_QUEUE_TAIL_EX_ALERT_IF_EMPTY)) { + if ((flags & 3) == TCL_QUEUE_TAIL) { /* * Append the event on the end of the queue. */ @@ -502,13 +500,12 @@ QueueEvent( evPtr->nextPtr = NULL; if (tsdPtr->firstEventPtr == NULL) { tsdPtr->firstEventPtr = evPtr; - wasEmpty = (position == TCL_QUEUE_TAIL_EX_ALERT_IF_EMPTY) ? 1 : 0; + wasEmpty = (flags & TCL_QUEUE_ALERT_IF_EMPTY) ? 1 : 0; } else { tsdPtr->lastEventPtr->nextPtr = evPtr; } tsdPtr->lastEventPtr = evPtr; - } else if ((position == TCL_QUEUE_HEAD_EX) || - (position == TCL_QUEUE_HEAD_EX_ALERT_IF_EMPTY)) { + } else if ((flags & 3) == TCL_QUEUE_HEAD) { /* * Push the event on the head of the queue. */ @@ -516,10 +513,10 @@ QueueEvent( evPtr->nextPtr = tsdPtr->firstEventPtr; if (tsdPtr->firstEventPtr == NULL) { tsdPtr->lastEventPtr = evPtr; - wasEmpty = (position == TCL_QUEUE_HEAD_EX_ALERT_IF_EMPTY) ? 1 : 0; + wasEmpty = (flags & TCL_QUEUE_ALERT_IF_EMPTY) ? 1 : 0; } tsdPtr->firstEventPtr = evPtr; - } else if (position == TCL_QUEUE_MARK_EX) { + } else if ((flags & 3) == TCL_QUEUE_MARK) { /* * Insert the event after the current marker event and advance the * marker to the new event. diff --git a/generic/tclTest.c b/generic/tclTest.c index 99fe92f..b29bb1c 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -2109,7 +2109,7 @@ TesteventObjCmd( "head", "tail", "mark", NULL }; int posIndex; /* Index of the chosen position */ - static const Tcl_QueuePosition posNum[] = { + static const int posNum[] = { /* Interpretation of the chosen position */ TCL_QUEUE_HEAD, TCL_QUEUE_TAIL, diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 887f645..1e8e013 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -878,7 +878,7 @@ ThreadSend( threadEventPtr->event.proc = ThreadEventProc; Tcl_ThreadQueueEvent(threadId, (Tcl_Event *) threadEventPtr, - TCL_QUEUE_TAIL_ALERT_IF_EMPTY); + TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY); if (!wait) { Tcl_MutexUnlock(&threadMutex); -- cgit v0.12 From 9fdb32b8e254da15698c28d65e281ee946a57eb5 Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 14 Mar 2022 15:46:35 +0000 Subject: TIP607 encoding failindex: start implementation --- generic/tclCmdAH.c | 66 +++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 48 insertions(+), 18 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 60a2c42..96bac4e 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -556,28 +556,59 @@ EncodingConvertfromObjCmd( int flags = TCL_ENCODING_NOCOMPLAIN; #endif size_t result; + Tcl_Obj *failVarObj = NULL; + int i, encodingSeen = 0; + /* + * Decode parameters: + * Possible combinations: + * 1) data -> objc = 2 + * 2) encoding data -> objc = 3 + * 3) -nocomplain data -> objc = 3 (8.7) + * 4) -nocomplain encoding data -> objc = 4 (8.7) + * 5) -failindex val data -> objc = 4 + * 6) -failindex val encoding data -> objc = 5 + * 7a) -nocomplain -failindex val data -> objc = 5 + * 7b) -failindex val -nocomplain data -> objc = 5 + * 8a) -nocomplain -failindex val encoding data -> objc = 6 + * 8b) -failindex val -nocomplain encoding data -> objc = 6 + */ - if (objc == 2) { - encoding = Tcl_GetEncoding(interp, NULL); - data = objv[1]; - } else if ((unsigned)(objc - 2) < 3) { + if (objc > 1 && objc < 7) { + int noComplaintSeen = 0; + int encodingSeen = 0; data = objv[objc - 1]; - bytesPtr = Tcl_GetString(objv[1]); - if (bytesPtr[0] == '-' && bytesPtr[1] == 'n' - && !strncmp(bytesPtr, "-nocomplain", strlen(bytesPtr))) { - flags = TCL_ENCODING_NOCOMPLAIN; - } else if (objc < 4) { - if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { - return TCL_ERROR; + for(i = 1; i < objc-1 ; i++ ) { + bytesPtr = Tcl_GetString(objv[i]); + if (bytesPtr[0] == '-' && bytesPtr[1] == 'n' + && !strncmp(bytesPtr, "-nocomplain", strlen(bytesPtr))) { + if (noComplaintSeen) { + goto encConvFromError; + } + flags = TCL_ENCODING_NOCOMPLAIN; + noComplaintSeen = 1; + } else if (bytesPtr[0] == '-' && bytesPtr[1] == 'f' + && !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) { + /* at least two additional arguments needed */ + if (objc < i + 3) { + goto encConvFromError; + } + if (failVarObj != NULL) { + goto encConvFromError; + } + i++; + failVarObj = objv[i]; + flags = TCL_ENCODING_NOCOMPLAIN; + } else if (i == objc - 2) { + if (Tcl_GetEncodingFromObj(interp, objv[i], &encoding) != TCL_OK) { + return TCL_ERROR; + } + encodingSeen = 1; + } else { + goto encConvFromError; } - goto encConvFromOK; - } else { - goto encConvFromError; } - if (objc < 4) { + if (!encodingSeen) { encoding = Tcl_GetEncoding(interp, NULL); - } else if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { - return TCL_ERROR; } } else { encConvFromError: @@ -585,7 +616,6 @@ EncodingConvertfromObjCmd( return TCL_ERROR; } -encConvFromOK: /* * Convert the string into a byte array in 'ds' */ -- cgit v0.12 From e1f11871dd6bf0d90bef16897153fd0c00c9d136 Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 14 Mar 2022 16:10:27 +0000 Subject: TIP607 encoding failindex: options -failindex and -nocomplain may not both be specified --- generic/tclCmdAH.c | 67 +++++++++++++++++++++++------------------------------- 1 file changed, 29 insertions(+), 38 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 96bac4e..6c15630 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -557,7 +557,6 @@ EncodingConvertfromObjCmd( #endif size_t result; Tcl_Obj *failVarObj = NULL; - int i, encodingSeen = 0; /* * Decode parameters: * Possible combinations: @@ -567,52 +566,44 @@ EncodingConvertfromObjCmd( * 4) -nocomplain encoding data -> objc = 4 (8.7) * 5) -failindex val data -> objc = 4 * 6) -failindex val encoding data -> objc = 5 - * 7a) -nocomplain -failindex val data -> objc = 5 - * 7b) -failindex val -nocomplain data -> objc = 5 - * 8a) -nocomplain -failindex val encoding data -> objc = 6 - * 8b) -failindex val -nocomplain encoding data -> objc = 6 */ - if (objc > 1 && objc < 7) { - int noComplaintSeen = 0; - int encodingSeen = 0; + if (objc == 2) { + encoding = Tcl_GetEncoding(interp, NULL); + data = objv[1]; + } else if ((unsigned)(objc - 2) < 4) { + int objcUnprocessed = objc; data = objv[objc - 1]; - for(i = 1; i < objc-1 ; i++ ) { - bytesPtr = Tcl_GetString(objv[i]); - if (bytesPtr[0] == '-' && bytesPtr[1] == 'n' - && !strncmp(bytesPtr, "-nocomplain", strlen(bytesPtr))) { - if (noComplaintSeen) { - goto encConvFromError; - } - flags = TCL_ENCODING_NOCOMPLAIN; - noComplaintSeen = 1; - } else if (bytesPtr[0] == '-' && bytesPtr[1] == 'f' - && !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) { - /* at least two additional arguments needed */ - if (objc < i + 3) { - goto encConvFromError; - } - if (failVarObj != NULL) { - goto encConvFromError; - } - i++; - failVarObj = objv[i]; - flags = TCL_ENCODING_NOCOMPLAIN; - } else if (i == objc - 2) { - if (Tcl_GetEncodingFromObj(interp, objv[i], &encoding) != TCL_OK) { - return TCL_ERROR; - } - encodingSeen = 1; - } else { + bytesPtr = Tcl_GetString(objv[1]); + if (bytesPtr[0] == '-' && bytesPtr[1] == 'n' + && !strncmp(bytesPtr, "-nocomplain", strlen(bytesPtr))) { + flags = TCL_ENCODING_NOCOMPLAIN; + objcUnprocessed--; + } else if (bytesPtr[0] == '-' && bytesPtr[1] == 'f' + && !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) { + /* at least two additional arguments needed */ + if (objc < 4) { goto encConvFromError; } + failVarObj = objv[2]; + flags = TCL_ENCODING_NOCOMPLAIN; + objcUnprocessed -= 2; } - if (!encodingSeen) { - encoding = Tcl_GetEncoding(interp, NULL); + switch (objcUnprocessed) { + case 2: + if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { + return TCL_ERROR; + } + break; + case 1: + encoding = Tcl_GetEncoding(interp, NULL); + break; + default: + goto encConvFromError; } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain|-failindex var? ?encoding? data"); return TCL_ERROR; } -- cgit v0.12 From 938fc2c7a0aef1a5d7655f1e0227d57b6d518f1d Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 14 Mar 2022 17:39:22 +0000 Subject: TIP607 encoding failindex: some tests and implementation (not working) --- generic/tclCmdAH.c | 37 ++++++++++++++++++++++++------------- tests/encoding.test | 28 +++++++++++++++++++++++++++- 2 files changed, 51 insertions(+), 14 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 6c15630..5b95e51 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -555,7 +555,7 @@ EncodingConvertfromObjCmd( #else int flags = TCL_ENCODING_NOCOMPLAIN; #endif - size_t result; + size_t result, errorPosition = 0; Tcl_Obj *failVarObj = NULL; /* * Decode parameters: @@ -571,7 +571,7 @@ EncodingConvertfromObjCmd( if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; - } else if ((unsigned)(objc - 2) < 4) { + } else if (objc > 2 && objc < 6) { int objcUnprocessed = objc; data = objv[objc - 1]; bytesPtr = Tcl_GetString(objv[1]); @@ -586,16 +586,16 @@ EncodingConvertfromObjCmd( goto encConvFromError; } failVarObj = objv[2]; - flags = TCL_ENCODING_NOCOMPLAIN; + flags = TCL_ENCODING_STOPONERROR; objcUnprocessed -= 2; } switch (objcUnprocessed) { - case 2: + case 3: if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { return TCL_ERROR; } break; - case 1: + case 2: encoding = Tcl_GetEncoding(interp, NULL); break; default: @@ -622,14 +622,25 @@ EncodingConvertfromObjCmd( result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, flags, &ds); if ((flags & TCL_ENCODING_STOPONERROR) && (result != (size_t)-1)) { - char buf[TCL_INTEGER_SPACE]; - sprintf(buf, "%" TCL_Z_MODIFIER "u", result); - Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte sequence starting at index %" - TCL_Z_MODIFIER "u: '\\x%X'", result, UCHAR(bytesPtr[result]))); - Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", - buf, NULL); - Tcl_DStringFree(&ds); - return TCL_ERROR; + if (failVarObj != NULL) { + /* I hope, wide int will cover size_t data type */ + if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + } else { + char buf[TCL_INTEGER_SPACE]; + sprintf(buf, "%" TCL_Z_MODIFIER "u", result); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte sequence starting at index %" + TCL_Z_MODIFIER "u: '\\x%X'", result, UCHAR(bytesPtr[result]))); + Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", + buf, NULL); + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + } else if (failVarObj != NULL) { + if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(-1), TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } } /* diff --git a/tests/encoding.test b/tests/encoding.test index bf82493..7020077 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -669,10 +669,36 @@ test encoding-24.21 {Parse with -nocomplain but without providing encoding} { } 1 test encoding-24.22 {Syntax error, two encodings} -body { encoding convertfrom iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-failindex var? ?encoding? data"} test encoding-24.23 {Syntax error, two encodings} -body { encoding convertto iso8859-1 utf-8 "ZX\uD800" } -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?encoding? data"} +test encoding-24.24 {Syntax error, no parameter} -body { + encoding convertfrom +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +test encoding-24.25 {Syntax error, -nocomplain and -failindex, no encoding} -body { + encoding convertfrom -nocomplain -failindex 2 ABC +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +test encoding-24.26 {Syntax error, -failindex and -nocomplain, no encoding} -body { + encoding convertfrom -failindex 2 -nocomplain ABC +} -returnCodes 1 -result {unknown encoding "-nocomplain"} +test encoding-24.27 {Syntax error, -nocomplain and -failindex, encoding} -body { + encoding convertfrom -nocomplain -failindex 2 utf-8 ABC +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +test encoding-24.28 {Syntax error, -failindex and -nocomplain, encoding} -body { + encoding convertfrom -failindex 2 -nocomplain utf-8 ABC +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +test encoding-24.29 {Syntax error, -failindex with no var, no encoding} -body { + encoding convertfrom -failindex ABC +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +test encoding-24.30 {convertrom -failindex with correct data} -body { + encoding convertfrom -failindex test ABC + set test +} -returnCodes 0 -result -1 +test encoding-24.31 {convertrom -failindex with incomplete utf8} -body { + set res [encoding convertfrom -failindex test A\xc3] + lappend res $test +} -returnCodes 0 -result {A 1} file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From 1975c98a5c09989a767f8288beec0e67abf408a3 Mon Sep 17 00:00:00 2001 From: oehhar Date: Tue, 15 Mar 2022 07:09:40 +0000 Subject: TIP607 encoding failindex: test correction --- tests/encoding.test | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/tests/encoding.test b/tests/encoding.test index 7a1e4e7..4284254 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -696,9 +696,10 @@ test encoding-24.30 {convertrom -failindex with correct data} -body { set test } -returnCodes 0 -result -1 test encoding-24.31 {convertrom -failindex with incomplete utf8} -body { - set res [encoding convertfrom -failindex test A\xc3] - lappend res $test -} -returnCodes 0 -result {A 1} + set x [encoding convertfrom -failindex i A\xc3] + binary scan $x H* y + list $y $i +} -returnCodes 0 -result {41 1} file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From 60b2db50fcc19a83a5c737e5cadfcbd8f7f3810b Mon Sep 17 00:00:00 2001 From: oehhar Date: Tue, 15 Mar 2022 10:15:30 +0000 Subject: win/makefile.vc: required correction for noembed,symbols to allow debugging with MS-VS2015. Otherwise, symbols are not detected within DLL. --- win/makefile.vc | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/win/makefile.vc b/win/makefile.vc index 2687e1c..d15f844 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -584,6 +584,7 @@ $(OUT_DIR)\tommath.lib: $(TOMMATHDIR)\win64\tommath.lib $(COPY) $(TOMMATHDIR)\win64\tommath.lib $(OUT_DIR)\tommath.lib !endif +!if $(TCL_EMBED_SCRIPTS) $(TCLSCRIPTZIP): $(TCLDDELIB) $(TCLREGLIB) @echo Building Tcl library zip file @if exist "$(LIBTCLVFS)" $(RMDIR) "$(LIBTCLVFS)" @@ -603,7 +604,7 @@ $(TCLSCRIPTZIP): $(TCLDDELIB) $(TCLREGLIB) @echo file delete -force {$@} > "$(OUT_DIR)\zipper.tcl" @echo zipfs mkzip {$@} {$(LIBTCLVFS)} {$(LIBTCLVFS)} >> "$(OUT_DIR)\zipper.tcl" @cd "$(OUT_DIR)" && $(TCLSH_NATIVE) zipper.tcl - +!endif pkgs: @for /d %d in ($(PKGSDIR)\*) do \ -- cgit v0.12 From ea69616a5dd24c1d6c78e20ee260956e766342ea Mon Sep 17 00:00:00 2001 From: oehhar Date: Tue, 15 Mar 2022 10:28:48 +0000 Subject: TIP607 encoding failindex: correct test which works now. --- tests/encoding.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/encoding.test b/tests/encoding.test index 4284254..f4343c4 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -696,7 +696,7 @@ test encoding-24.30 {convertrom -failindex with correct data} -body { set test } -returnCodes 0 -result -1 test encoding-24.31 {convertrom -failindex with incomplete utf8} -body { - set x [encoding convertfrom -failindex i A\xc3] + set x [encoding convertfrom -failindex i utf-8 A\xc3] binary scan $x H* y list $y $i } -returnCodes 0 -result {41 1} -- cgit v0.12 From 48a30dd04e32f374258f8f6eacc40c48a1227ee7 Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 16 Mar 2022 18:20:29 +0000 Subject: TIP607 encoding failindex: revert ckeckin [add9ed8887] : just wait for symbol load in VS2015 and it will work. Sorry, Ashok ! --- win/makefile.vc | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/win/makefile.vc b/win/makefile.vc index d15f844..abbf840 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -52,7 +52,7 @@ # turn on the 64-bit compiler, if your SDK has it. # # Basic macros and options usable on the commandline (see rules.vc for more info): -# OPTS=nomsvcrt,noembed,nothreads,pdbs,profile,static,symbols,thrdalloc,unchecked,none +# OPTS=nomsvcrt,noembed,nothreads,pdbs,profile,static,symbols,thrdalloc,unchecked,utf16,none # Sets special options for the core. The default is for none. # Any combination of the above may be used (comma separated). # 'none' will over-ride everything to nothing. @@ -584,7 +584,6 @@ $(OUT_DIR)\tommath.lib: $(TOMMATHDIR)\win64\tommath.lib $(COPY) $(TOMMATHDIR)\win64\tommath.lib $(OUT_DIR)\tommath.lib !endif -!if $(TCL_EMBED_SCRIPTS) $(TCLSCRIPTZIP): $(TCLDDELIB) $(TCLREGLIB) @echo Building Tcl library zip file @if exist "$(LIBTCLVFS)" $(RMDIR) "$(LIBTCLVFS)" @@ -604,7 +603,7 @@ $(TCLSCRIPTZIP): $(TCLDDELIB) $(TCLREGLIB) @echo file delete -force {$@} > "$(OUT_DIR)\zipper.tcl" @echo zipfs mkzip {$@} {$(LIBTCLVFS)} {$(LIBTCLVFS)} >> "$(OUT_DIR)\zipper.tcl" @cd "$(OUT_DIR)" && $(TCLSH_NATIVE) zipper.tcl -!endif + pkgs: @for /d %d in ($(PKGSDIR)\*) do \ -- cgit v0.12 From 190439cf96a3f4399b008c47251c4f9956c61878 Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 17 Mar 2022 13:23:30 +0000 Subject: TIP607 encoding failindex: correct error message, test bytecompiled version --- generic/tclCmdAH.c | 2 +- tests/encoding.test | 51 ++++++++++++++++++++++++++++++++++++++++++--------- 2 files changed, 43 insertions(+), 10 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index b152369..9772c56 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -467,7 +467,7 @@ EncodingConvertfromObjCmd( } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain|-failindex var? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-failindex var? ?encoding? data"); return TCL_ERROR; } diff --git a/tests/encoding.test b/tests/encoding.test index f4343c4..9bd0e6b 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -669,37 +669,70 @@ test encoding-24.21 {Parse with -nocomplain but without providing encoding} { } 1 test encoding-24.22 {Syntax error, two encodings} -body { encoding convertfrom iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} test encoding-24.23 {Syntax error, two encodings} -body { encoding convertto iso8859-1 utf-8 "ZX\uD800" } -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?encoding? data"} test encoding-24.24 {Syntax error, no parameter} -body { encoding convertfrom -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} test encoding-24.25 {Syntax error, -nocomplain and -failindex, no encoding} -body { encoding convertfrom -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} test encoding-24.26 {Syntax error, -failindex and -nocomplain, no encoding} -body { encoding convertfrom -failindex 2 -nocomplain ABC } -returnCodes 1 -result {unknown encoding "-nocomplain"} test encoding-24.27 {Syntax error, -nocomplain and -failindex, encoding} -body { encoding convertfrom -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} test encoding-24.28 {Syntax error, -failindex and -nocomplain, encoding} -body { encoding convertfrom -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} -test encoding-24.29 {Syntax error, -failindex with no var, no encoding} -body { +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-24.29.1 {Syntax error, -failindex with no var, no encoding} -body { encoding convertfrom -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-failindex var? ?encoding? data"} -test encoding-24.30 {convertrom -failindex with correct data} -body { +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-24.29.2 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { + proc encoding_test {} { + encoding convertfrom -failindex ABC + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} -cleanup { + rename encoding_test "" +} +test encoding-24.30.1 {convertrom -failindex with correct data} -body { encoding convertfrom -failindex test ABC set test } -returnCodes 0 -result -1 -test encoding-24.31 {convertrom -failindex with incomplete utf8} -body { +test encoding-24.30.2 {convertrom -failindex with correct data (byt compiled)} -setup { + proc encoding_test {} { + encoding convertfrom -failindex test ABC + set test + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 0 -result -1 -cleanup { + rename encoding_test "" +} +test encoding-24.31.1 {convertrom -failindex with incomplete utf8} -body { set x [encoding convertfrom -failindex i utf-8 A\xc3] binary scan $x H* y list $y $i } -returnCodes 0 -result {41 1} +test encoding-24.31.2 {convertrom -failindex with incomplete utf8 (byte compiled)} -setup { + proc encoding_test {} { + set x [encoding convertfrom -failindex i utf-8 A\xc3] + binary scan $x H* y + list $y $i + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 0 -result {41 1} -cleanup { + rename encoding_test "" +} file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From 3fb8ab60ef408acf79ad86e0ceef78d7e90650ea Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 17 Mar 2022 16:30:59 +0000 Subject: TIP607 encoding failindex: also implement encoding convertto, move tests to cmdAH.test, as the other user interface tests (expect one) is also there. --- generic/tclCmdAH.c | 89 ++++++++++++++++++++++++++------------- tests/cmdAH.test | 119 +++++++++++++++++++++++++++++++++++++++++++++++++++- tests/encoding.test | 31 +------------- 3 files changed, 180 insertions(+), 59 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 95ca18a..70767ae 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -426,8 +426,8 @@ EncodingConvertfromObjCmd( * Possible combinations: * 1) data -> objc = 2 * 2) encoding data -> objc = 3 - * 3) -nocomplain data -> objc = 3 (8.7) - * 4) -nocomplain encoding data -> objc = 4 (8.7) + * 3) -nocomplain data -> objc = 3 + * 4) -nocomplain encoding data -> objc = 4 * 5) -failindex val data -> objc = 4 * 6) -failindex val encoding data -> objc = 5 */ @@ -467,7 +467,7 @@ EncodingConvertfromObjCmd( } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain|-failindex var? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-failindex var? ?encoding? data"); return TCL_ERROR; } @@ -544,42 +544,64 @@ EncodingConverttoObjCmd( Tcl_Encoding encoding; /* Encoding to use */ size_t length; /* Length of the string being converted */ const char *stringPtr; /* Pointer to the first byte of the string */ - size_t result; + size_t result, errorPosition = 0; + Tcl_Obj *failVarObj = NULL; #if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) int flags = TCL_ENCODING_STOPONERROR; #else int flags = TCL_ENCODING_NOCOMPLAIN; #endif + /* + * Decode parameters: + * Possible combinations: + * 1) data -> objc = 2 + * 2) encoding data -> objc = 3 + * 3) -nocomplain data -> objc = 3 + * 4) -nocomplain encoding data -> objc = 4 + * 5) -failindex val data -> objc = 4 + * 6) -failindex val encoding data -> objc = 5 + */ + if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; - } else if ((unsigned)(objc - 2) < 3) { + } else if (objc > 2 && objc < 6) { + int objcUnprocessed = objc; data = objv[objc - 1]; stringPtr = Tcl_GetString(objv[1]); if (stringPtr[0] == '-' && stringPtr[1] == 'n' && !strncmp(stringPtr, "-nocomplain", strlen(stringPtr))) { flags = TCL_ENCODING_NOCOMPLAIN; - } else if (objc < 4) { - if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { - return TCL_ERROR; + objcUnprocessed--; + } else if (stringPtr[0] == '-' && stringPtr[1] == 'f' + && !strncmp(stringPtr, "-failindex", strlen(stringPtr))) { + /* at least two additional arguments needed */ + if (objc < 4) { + goto encConvToError; } - goto encConvToOK; - } else { - goto encConvToError; + failVarObj = objv[2]; + flags = TCL_ENCODING_STOPONERROR; + objcUnprocessed -= 2; } - if (objc < 4) { - encoding = Tcl_GetEncoding(interp, NULL); - } else if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { - return TCL_ERROR; + switch (objcUnprocessed) { + case 3: + if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { + return TCL_ERROR; + } + break; + case 2: + encoding = Tcl_GetEncoding(interp, NULL); + break; + default: + goto encConvToError; } } else { encConvToError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-failindex var? ?encoding? data"); return TCL_ERROR; } -encConvToOK: /* * Convert the string to a byte array in 'ds' */ @@ -588,17 +610,28 @@ encConvToOK: result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, flags, &ds); if ((flags & TCL_ENCODING_STOPONERROR) && (result != (size_t)-1)) { - size_t pos = Tcl_NumUtfChars(stringPtr, result); - int ucs4; - char buf[TCL_INTEGER_SPACE]; - TclUtfToUCS4(&stringPtr[result], &ucs4); - sprintf(buf, "%" TCL_Z_MODIFIER "u", result); - Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected character at index %" - TCL_Z_MODIFIER "u: 'U+%06X'", pos, ucs4)); - Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", - buf, NULL); - Tcl_DStringFree(&ds); - return TCL_ERROR; + if (failVarObj != NULL) { + /* I hope, wide int will cover size_t data type */ + if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + } else { + size_t pos = Tcl_NumUtfChars(stringPtr, result); + int ucs4; + char buf[TCL_INTEGER_SPACE]; + TclUtfToUCS4(&stringPtr[result], &ucs4); + sprintf(buf, "%" TCL_Z_MODIFIER "u", result); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected character at index %" + TCL_Z_MODIFIER "u: 'U+%06X'", pos, ucs4)); + Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", + buf, NULL); + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + } else if (failVarObj != NULL) { + if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(-1), TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } } Tcl_SetObjResult(interp, Tcl_NewByteArrayObj((unsigned char*) Tcl_DStringValue(&ds), diff --git a/tests/cmdAH.test b/tests/cmdAH.test index d7be68b..facf67d 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -172,7 +172,7 @@ test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto -} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto foo bar } -result {unknown encoding "foo"} @@ -194,7 +194,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { } -result 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom foo bar } -result {unknown encoding "foo"} @@ -229,6 +229,121 @@ test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { encoding system $system } -result iso8859-1 +test encoding-4.14.1 {Syntax error, -nocomplain and -failindex, no encoding} -body { + encoding convertfrom -nocomplain -failindex 2 ABC +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-4.14.2 {Syntax error, -nocomplain and -failindex, no encoding} -body { + encoding convertto -nocomplain -failindex 2 ABC +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-4.15.1 {Syntax error, -failindex and -nocomplain, no encoding} -body { + encoding convertfrom -failindex 2 -nocomplain ABC +} -returnCodes 1 -result {unknown encoding "-nocomplain"} +test encoding-4.15.2 {Syntax error, -failindex and -nocomplain, no encoding} -body { + encoding convertto -failindex 2 -nocomplain ABC +} -returnCodes 1 -result {unknown encoding "-nocomplain"} +test encoding-4.16.1 {Syntax error, -nocomplain and -failindex, encoding} -body { + encoding convertfrom -nocomplain -failindex 2 utf-8 ABC +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-4.16.2 {Syntax error, -nocomplain and -failindex, encoding} -body { + encoding convertto -nocomplain -failindex 2 utf-8 ABC +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-4.17.1 {Syntax error, -failindex and -nocomplain, encoding} -body { + encoding convertfrom -failindex 2 -nocomplain utf-8 ABC +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-4.17.2 {Syntax error, -failindex and -nocomplain, encoding} -body { + encoding convertto -failindex 2 -nocomplain utf-8 ABC +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-4.18.1 {Syntax error, -failindex with no var, no encoding} -body { + encoding convertfrom -failindex ABC +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { + proc encoding_test {} { + encoding convertfrom -failindex ABC + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} -cleanup { + rename encoding_test "" +} +test encoding-4.18.3 {Syntax error, -failindex with no var, no encoding} -body { + encoding convertto -failindex ABC +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +test encoding-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { + proc encoding_test {} { + encoding convertto -failindex ABC + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-failindex var? ?encoding? data"} -cleanup { + rename encoding_test "" +} +test encoding-4.19.1 {convertrom -failindex with correct data} -body { + encoding convertfrom -failindex test ABC + set test +} -returnCodes 0 -result -1 +test encoding-4.19.2 {convertrom -failindex with correct data (byt compiled)} -setup { + proc encoding_test {} { + encoding convertfrom -failindex test ABC + set test + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 0 -result -1 -cleanup { + rename encoding_test "" +} +test encoding-4.19.3 {convertrom -failindex with correct data} -body { + encoding convertto -failindex test ABC + set test +} -returnCodes 0 -result -1 +test encoding-4.19.4 {convertrom -failindex with correct data (byt compiled)} -setup { + proc encoding_test {} { + encoding convertto -failindex test ABC + set test + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 0 -result -1 -cleanup { + rename encoding_test "" +} +test encoding-4.20.1 {convertrom -failindex with incomplete utf8} -body { + set x [encoding convertfrom -failindex i utf-8 A\xc3] + binary scan $x H* y + list $y $i +} -returnCodes 0 -result {41 1} +test encoding-4.20.2 {convertrom -failindex with incomplete utf8 (byte compiled)} -setup { + proc encoding_test {} { + set x [encoding convertfrom -failindex i utf-8 A\xc3] + binary scan $x H* y + list $y $i + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 0 -result {41 1} -cleanup { + rename encoding_test "" +} +test encoding-4.21.1 {convertto -failindex with wrong character} -body { + set x [encoding convertto -failindex i iso8859-1 A\u0141] + binary scan $x H* y + list $y $i +} -returnCodes 0 -result {41 1} +test encoding-4.20.2 {convertto -failindex with wrong character (byte compiled)} -setup { + proc encoding_test {} { + set x [encoding convertto -failindex i iso8859-1 A\u0141] + binary scan $x H* y + list $y $i + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 0 -result {41 1} -cleanup { + rename encoding_test "" +} + test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { file } -result {wrong # args: should be "file subcommand ?arg ...?"} diff --git a/tests/encoding.test b/tests/encoding.test index 061bc11..5c06b38 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -667,37 +667,10 @@ test encoding-24.21 {Parse with -nocomplain but without providing encoding} { } 1 test encoding-24.22 {Syntax error, two encodings} -body { encoding convertfrom iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} test encoding-24.23 {Syntax error, two encodings} -body { encoding convertto iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?encoding? data"} -test encoding-24.24 {Syntax error, no parameter} -body { - encoding convertfrom -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} -test encoding-24.25 {Syntax error, -nocomplain and -failindex, no encoding} -body { - encoding convertfrom -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} -test encoding-24.26 {Syntax error, -failindex and -nocomplain, no encoding} -body { - encoding convertfrom -failindex 2 -nocomplain ABC -} -returnCodes 1 -result {unknown encoding "-nocomplain"} -test encoding-24.27 {Syntax error, -nocomplain and -failindex, encoding} -body { - encoding convertfrom -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} -test encoding-24.28 {Syntax error, -failindex and -nocomplain, encoding} -body { - encoding convertfrom -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} -test encoding-24.29 {Syntax error, -failindex with no var, no encoding} -body { - encoding convertfrom -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-failindex var? ?encoding? data"} -test encoding-24.30 {convertrom -failindex with correct data} -body { - encoding convertfrom -failindex test ABC - set test -} -returnCodes 0 -result -1 -test encoding-24.31 {convertrom -failindex with incomplete utf8} -body { - set x [encoding convertfrom -failindex i utf-8 A\xc3] - binary scan $x H* y - list $y $i -} -returnCodes 0 -result {41 1} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-failindex var? ?encoding? data"} file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From ce98d31d01017d2ce8876a1df05eb0d0cf98c0c9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Mar 2022 17:52:46 +0000 Subject: Eliminate "deprecated" constraint: doens't exist in 9.0 any more. Also remove unused variable --- generic/tclCmdAH.c | 2 +- tests/http.test | 2 +- tests/main.test | 2 +- tests/safe.test | 4 ++-- tests/source.test | 2 +- 5 files changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 49c7d05..597bb3b 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -539,7 +539,7 @@ EncodingConverttoObjCmd( Tcl_Encoding encoding; /* Encoding to use */ size_t length; /* Length of the string being converted */ const char *stringPtr; /* Pointer to the first byte of the string */ - size_t result, errorPosition = 0; + size_t result; Tcl_Obj *failVarObj = NULL; int flags = 0; diff --git a/tests/http.test b/tests/http.test index e09992d..3b2963e 100644 --- a/tests/http.test +++ b/tests/http.test @@ -661,7 +661,7 @@ test http-7.3 {http::formatQuery} -setup { } -cleanup { http::config -urlencoding $enc } -result "can't read \"formMap(∈)\": no such element in array" -test http-7.4 {http::formatQuery} -constraints deprecated -setup { +test http-7.4 {http::formatQuery} -setup { set enc [http::config -urlencoding] } -body { http::config -urlencoding "iso8859-1" diff --git a/tests/main.test b/tests/main.test index 47b2f1a..4aadd79 100644 --- a/tests/main.test +++ b/tests/main.test @@ -143,7 +143,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-1.8 { Tcl_Main: startup script - -encoding option - mismatched encodings } -constraints { - stdio deprecated + stdio } -setup { set script [makeFile {} script] file delete $script diff --git a/tests/safe.test b/tests/safe.test index d93cb6b..76aeb41 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1269,7 +1269,7 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1278,7 +1278,7 @@ test safe-11.7.1 {testing safe encoding} -setup { } -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-failindex var? ?encoding? data" +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data" while executing "encoding convertfrom" invoked from within diff --git a/tests/source.test b/tests/source.test index 0a9a49f..98aaee2 100644 --- a/tests/source.test +++ b/tests/source.test @@ -275,7 +275,7 @@ test source-7.5 {source -encoding: correct operation} -setup { removeFile source.file rename € {} } -result foo -test source-7.6 {source -encoding: mismatch encoding error} -constraints deprecated -setup { +test source-7.6 {source -encoding: mismatch encoding error} -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] -- cgit v0.12 From ff13acf40513006ce3d0e56049498e5b11cf95bd Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 17 Mar 2022 19:48:40 +0000 Subject: TIP607 encoding failindex: user documentation --- doc/encoding.n | 75 +++++++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 59 insertions(+), 16 deletions(-) diff --git a/doc/encoding.n b/doc/encoding.n index e78a8e7..2277f9d 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -14,16 +14,10 @@ encoding \- Manipulate encodings .BE .SH INTRODUCTION .PP -Strings in Tcl are logically a sequence of 16-bit Unicode characters. +Strings in Tcl are logically a sequence of Unicode characters. These strings are represented in memory as a sequence of bytes that -may be in one of several encodings: modified UTF\-8 (which uses 1 to 3 -bytes per character), 16-bit -.QW Unicode -(which uses 2 bytes per character, with an endianness that is -dependent on the host architecture), and binary (which uses a single -byte per character but only handles a restricted range of characters). -Tcl does not guarantee to always use the same encoding for the same -string. +may be in one of several encodings: modified UTF\-8 (which uses 1 to 4 +bytes per character), or a custom encoding start as 8 bit binary data. .PP Different operating system interfaces or applications may generate strings in other encodings such as Shift\-JIS. The \fBencoding\fR @@ -34,16 +28,30 @@ formats. Performs one of several encoding related operations, depending on \fIoption\fR. The legal \fIoption\fRs are: .TP -\fBencoding convertfrom\fR ?\fIencoding\fR? \fIdata\fR +\fBencoding convertfrom\fR ?\fB-nocomplain\fR? ?\fB-failindex var\fR? +?\fIencoding\fR? \fIdata\fR . -Convert \fIdata\fR to Unicode from the specified \fIencoding\fR. The -characters in \fIdata\fR are treated as binary data where the lower -8-bits of each character is taken as a single byte. The resulting -sequence of bytes is treated as a string in the specified -\fIencoding\fR. If \fIencoding\fR is not specified, the current +Convert \fIdata\fR to a Unicode string from the specified \fIencoding\fR. The +characters in \fIdata\fR are 8 bit binary data. The resulting +sequence of bytes is a string created by applying the given \fIencoding\fR +to the data. If \fIencoding\fR is not specified, the current system encoding is used. +. +The call fails on convertion errors, like an incomplete utf-8 sequence. +The option \fB-failindex\fR is followed by a variable name. The variable +is set to \fI-1\fR if no conversion error occured. It is set to the +first error location in \fIdata\fR in case of a conversion error. All data +until this error location is transformed and retured. This option may not +be used together with \fB-nocomplain\fR. +. +The call does not fail on conversion errors, if the option +\fB-nocomplain\fR is given. In this case, any error locations are replaced +by \fB?\fR. Incomplete sequences are written verbatim to the output string. +The purpose of this switch is to gain compatibility to prior versions of TCL. +It is not recommended for any other usage. .TP -\fBencoding convertto\fR ?\fIencoding\fR? \fIstring\fR +\fBencoding convertto\fR ?\fB-nocomplain\fR? ?\fB-failindex var\fR? +?\fIencoding\fR? \fIstring\fR . Convert \fIstring\fR from Unicode to the specified \fIencoding\fR. The result is a sequence of bytes that represents the converted @@ -51,6 +59,21 @@ string. Each byte is stored in the lower 8-bits of a Unicode character (indeed, the resulting string is a binary string as far as Tcl is concerned, at least initially). If \fIencoding\fR is not specified, the current system encoding is used. +. +The call fails on convertion errors, like a Unicode character not representable +in the given \fIencoding\fR. +. +The option \fB-failindex\fR is followed by a variable name. The variable +is set to \fI-1\fR if no conversion error occured. It is set to the +first error location in \fIdata\fR in case of a conversion error. All data +until this error location is transformed and retured. This option may not +be used together with \fB-nocomplain\fR. +. +The call does not fail on conversion errors, if the option +\fB-nocomplain\fR is given. In this case, any error locations are replaced +by \fB?\fR. Incomplete sequences are written verbatim to the output string. +The purpose of this switch is to gain compatibility to prior versions of TCL. +It is not recommended for any other usage. .TP \fBencoding dirs\fR ?\fIdirectoryList\fR? . @@ -90,6 +113,26 @@ set s [\fBencoding convertfrom\fR euc-jp "\exA4\exCF"] The result is the unicode codepoint: .QW "\eu306F" , which is the Hiragana letter HA. +.PP +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"] +A +% set i +1 +.CE +.PP +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"] +A +% set i +1 +.CE +.PP .SH "SEE ALSO" Tcl_GetEncoding(3) .SH KEYWORDS -- cgit v0.12 From f527a3f4568093147bf17db414cc0340bbac5045 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Jun 2022 15:33:48 +0000 Subject: more "unsigned int" -> TCL_HASH_TYPE --- generic/tcl.h | 2 +- generic/tclCompile.h | 16 ++++++++-------- generic/tclInt.h | 50 +++++++++++++++++++++++++------------------------- 3 files changed, 34 insertions(+), 34 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 61b0c48..94c236a 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1291,7 +1291,7 @@ typedef struct Tcl_HashSearch { typedef struct { void *next; /* Search position for underlying hash * table. */ - unsigned int epoch; /* Epoch marker for dictionary being searched, + TCL_HASH_TYPE epoch; /* Epoch marker for dictionary being searched, * or 0 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ } Tcl_DictSearch; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index ae30c19..1f40d46 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -135,7 +135,7 @@ typedef struct ExceptionAux { int numBreakTargets; /* The number of [break]s that want to be * targeted to the place where this loop * exception will be bound to. */ - unsigned int *breakTargets; /* The offsets of the INST_JUMP4 instructions + TCL_HASH_TYPE *breakTargets; /* The offsets of the INST_JUMP4 instructions * issued by the [break]s that we must * update. Note that resizing a jump (via * TclFixupForwardJump) can cause the contents @@ -145,7 +145,7 @@ typedef struct ExceptionAux { int numContinueTargets; /* The number of [continue]s that want to be * targeted to the place where this loop * exception will be bound to. */ - unsigned int *continueTargets; /* The offsets of the INST_JUMP4 instructions + TCL_HASH_TYPE *continueTargets; /* The offsets of the INST_JUMP4 instructions * issued by the [continue]s that we must * update. Note that resizing a jump (via * TclFixupForwardJump) can cause the contents @@ -221,7 +221,7 @@ typedef void *(AuxDataDupProc) (void *clientData); typedef void (AuxDataFreeProc) (void *clientData); typedef void (AuxDataPrintProc)(void *clientData, Tcl_Obj *appendObj, struct ByteCode *codePtr, - unsigned int pcOffset); + TCL_HASH_TYPE pcOffset); /* * We define a separate AuxDataType struct to hold type-related information @@ -417,7 +417,7 @@ typedef struct ByteCode { * procs are specific to an interpreter so the * code emitted will depend on the * interpreter. */ - unsigned int compileEpoch; /* Value of iPtr->compileEpoch when this + TCL_HASH_TYPE compileEpoch; /* Value of iPtr->compileEpoch when this * ByteCode was compiled. Used to invalidate * code when, e.g., commands with compile * procs are redefined. */ @@ -425,11 +425,11 @@ typedef struct ByteCode { * compiled. If the code is executed if a * different namespace, it must be * recompiled. */ - unsigned int nsEpoch; /* Value of nsPtr->resolverEpoch when this + TCL_HASH_TYPE nsEpoch; /* Value of nsPtr->resolverEpoch when this * ByteCode was compiled. Used to invalidate * code when new namespace resolution rules * are put into effect. */ - unsigned int refCount; /* Reference count: set 1 when created plus 1 + TCL_HASH_TYPE refCount; /* Reference count: set 1 when created plus 1 * for each execution of the code currently * active. This structure can be freed when * refCount becomes zero. */ @@ -1124,7 +1124,7 @@ MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size); MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, - int length, unsigned int hash, int *newPtr, + int length, TCL_HASH_TYPE hash, int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr); MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr); @@ -1138,7 +1138,7 @@ MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); -MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, unsigned int index); +MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, TCL_HASH_TYPE index); MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars, int create, CompileEnv *envPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, diff --git a/generic/tclInt.h b/generic/tclInt.h index 72107ef..7425123 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -298,7 +298,7 @@ typedef struct Namespace { * frames for this namespace that are on the * Tcl call stack. The namespace won't be * freed until activationCount becomes zero. */ - unsigned int refCount; /* Count of references by namespaceName + TCL_HASH_TYPE refCount; /* Count of references by namespaceName * objects. The namespace can't be freed until * refCount becomes zero. */ Tcl_HashTable cmdTable; /* Contains all the commands currently @@ -323,12 +323,12 @@ typedef struct Namespace { * registered using "namespace export". */ int maxExportPatterns; /* Mumber of export patterns for which space * is currently allocated. */ - unsigned int cmdRefEpoch; /* Incremented if a newly added command + TCL_HASH_TYPE cmdRefEpoch; /* Incremented if a newly added command * shadows a command for which this namespace * has already cached a Command* pointer; this * causes all its cached Command* pointers to * be invalidated. */ - unsigned int resolverEpoch; /* Incremented whenever (a) the name + TCL_HASH_TYPE resolverEpoch; /* Incremented whenever (a) the name * resolution rules change for this namespace * or (b) a newly added command shadows a * command that is compiled to bytecodes. This @@ -355,7 +355,7 @@ typedef struct Namespace { * LookupCompiledLocal to resolve variable * references within the namespace at compile * time. */ - unsigned int exportLookupEpoch; /* Incremented whenever a command is added to + TCL_HASH_TYPE exportLookupEpoch; /* Incremented whenever a command is added to * a namespace, removed from a namespace or * the exports of a namespace are changed. * Allows TIP#112-driven command lists to be @@ -455,7 +455,7 @@ typedef struct EnsembleConfig { * if the command has been deleted (or never * existed; the global namespace never has an * ensemble command.) */ - unsigned int epoch; /* The epoch at which this ensemble's table of + TCL_HASH_TYPE epoch; /* The epoch at which this ensemble's table of * exported commands is valid. */ char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all * consistent points, this will have the same @@ -568,7 +568,7 @@ typedef struct CommandTrace { struct CommandTrace *nextPtr; /* Next in list of traces associated with a * particular command. */ - unsigned int refCount; /* Used to ensure this structure is not + TCL_HASH_TYPE refCount; /* Used to ensure this structure is not * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ @@ -641,7 +641,7 @@ typedef struct Var { typedef struct VarInHash { Var var; - unsigned int refCount; /* Counts number of active uses of this + TCL_HASH_TYPE refCount; /* Counts number of active uses of this * variable: 1 for the entry in the hash * table, 1 for each additional variable whose * linkPtr points here, 1 for each nested @@ -978,7 +978,7 @@ typedef struct CompiledLocal { typedef struct Proc { struct Interp *iPtr; /* Interpreter for which this command is * defined. */ - unsigned int refCount; /* Reference count: 1 if still present in + TCL_HASH_TYPE refCount; /* Reference count: 1 if still present in * command table plus 1 for each call to the * procedure that is currently active. This * structure can be freed when refCount @@ -1095,7 +1095,7 @@ typedef struct AssocData { */ typedef struct LocalCache { - unsigned int refCount; + TCL_HASH_TYPE refCount; int numVars; Tcl_Obj *varName0; } LocalCache; @@ -1261,7 +1261,7 @@ typedef struct CmdFrame { typedef struct CFWord { CmdFrame *framePtr; /* CmdFrame to access. */ int word; /* Index of the word in the command. */ - unsigned int refCount; /* Number of times the word is on the + TCL_HASH_TYPE refCount; /* Number of times the word is on the * stack. */ } CFWord; @@ -1529,7 +1529,7 @@ typedef struct LiteralEntry { * NULL if end of chain. */ Tcl_Obj *objPtr; /* Points to Tcl object that holds the * literal's bytes and length. */ - unsigned int refCount; /* If in an interpreter's global literal + TCL_HASH_TYPE refCount; /* If in an interpreter's global literal * table, the number of ByteCode structures * that share the literal object; the literal * entry can be freed when refCount drops to @@ -1547,13 +1547,13 @@ typedef struct LiteralTable { LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; /* Bucket array used for small tables to avoid * mallocs and frees. */ - unsigned int numBuckets; /* Total number of buckets allocated at + TCL_HASH_TYPE numBuckets; /* Total number of buckets allocated at * **buckets. */ - unsigned int numEntries; /* Total number of entries present in + TCL_HASH_TYPE numEntries; /* Total number of entries present in * table. */ - unsigned int rebuildSize; /* Enlarge table when numEntries gets to be + TCL_HASH_TYPE rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ - unsigned int mask; /* Mask value used in hashing function. */ + TCL_HASH_TYPE mask; /* Mask value used in hashing function. */ } LiteralTable; /* @@ -1671,12 +1671,12 @@ typedef struct Command { * recreated). */ Namespace *nsPtr; /* Points to the namespace containing this * command. */ - unsigned int refCount; /* 1 if in command hashtable plus 1 for each + TCL_HASH_TYPE refCount; /* 1 if in command hashtable plus 1 for each * reference from a CmdName Tcl object * representing a command's name in a ByteCode * instruction sequence. This structure can be * freed when refCount becomes zero. */ - unsigned int cmdEpoch; /* Incremented to invalidate any references + TCL_HASH_TYPE cmdEpoch; /* Incremented to invalidate any references * that point to this command when it is * renamed, deleted, hidden, or exposed. */ CompileProc *compileProc; /* Procedure called to compile command. NULL @@ -1942,7 +1942,7 @@ typedef struct Interp { * compiled by the interpreter. Indexed by the * string representations of literals. Used to * avoid creating duplicate objects. */ - unsigned int compileEpoch; /* Holds the current "compilation epoch" for + TCL_HASH_TYPE compileEpoch; /* Holds the current "compilation epoch" for * this interpreter. This is incremented to * invalidate existing ByteCodes when, e.g., a * command with a compile procedure is @@ -2432,7 +2432,7 @@ typedef enum TclEolTranslation { */ typedef struct List { - unsigned int refCount; + TCL_HASH_TYPE refCount; int maxElemCount; /* Total number of element array slots. */ int elemCount; /* Current number of list elements. */ int canonicalFlag; /* Set if the string representation was @@ -2656,7 +2656,7 @@ typedef Tcl_ObjCmdProc *TclObjCmdProcType; *---------------------------------------------------------------- */ -typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, unsigned int *lengthPtr, +typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr); /* @@ -2668,9 +2668,9 @@ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, unsigned int *leng */ typedef struct ProcessGlobalValue { - unsigned int epoch; /* Epoch counter to detect changes in the + TCL_HASH_TYPE epoch; /* Epoch counter to detect changes in the * global value. */ - unsigned int numBytes; /* Length of the global string. */ + TCL_HASH_TYPE numBytes; /* Length of the global string. */ char *value; /* The global string value. */ Tcl_Encoding encoding; /* system encoding when global string was * initialized. */ @@ -3043,7 +3043,7 @@ MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, - unsigned int *sizePtr); + TCL_HASH_TYPE *sizePtr); MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp, const char *targetName, const char *packageName); @@ -3160,7 +3160,7 @@ MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, int stackSize, int flags); MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, - unsigned int *lengthPtr, Tcl_Encoding *encodingPtr); + TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE ClientData TclpInitNotifier(void); MODULE_SCOPE void TclpInitPlatform(void); @@ -4541,7 +4541,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, (objPtr)->bytes = &tclEmptyString; \ (objPtr)->length = 0; \ } else { \ - (objPtr)->bytes = (char *)ckalloc((unsigned int)(len) + 1U); \ + (objPtr)->bytes = (char *)ckalloc((len) + 1U); \ memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)); \ (objPtr)->bytes[len] = '\0'; \ (objPtr)->length = (len); \ -- cgit v0.12 From 5bad06a9a453a043661695e582ef7c9f7f3647fc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Jun 2022 07:11:17 +0000 Subject: Don't use (unsigned)-1 -> TCL_INDEX_NONE --- generic/tclInt.h | 4 ++-- generic/tclLiteral.c | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 7425123..f5628f7 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1529,11 +1529,11 @@ typedef struct LiteralEntry { * NULL if end of chain. */ Tcl_Obj *objPtr; /* Points to Tcl object that holds the * literal's bytes and length. */ - TCL_HASH_TYPE refCount; /* If in an interpreter's global literal + int refCount; /* If in an interpreter's global literal * table, the number of ByteCode structures * that share the literal object; the literal * entry can be freed when refCount drops to - * 0. If in a local literal table, (unsigned)-1. */ + * 0. If in a local literal table, TCL_INDEX_NONE. */ Namespace *nsPtr; /* Namespace in which this literal is used. We * try to avoid sharing literal non-FQ command * names among different namespaces to reduce diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index e1943a1..0c2c545 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -229,7 +229,7 @@ TclCreateLiteral( if (flags & LITERAL_ON_HEAP) { ckfree(bytes); } - if (globalPtr->refCount != (unsigned) -1) { + if (globalPtr->refCount != TCL_INDEX_NONE) { globalPtr->refCount++; } return objPtr; @@ -630,7 +630,7 @@ TclAddLiteralObj( lPtr = &envPtr->literalArrayPtr[objIndex]; lPtr->objPtr = objPtr; Tcl_IncrRefCount(objPtr); - lPtr->refCount = (unsigned) -1; /* i.e., unused */ + lPtr->refCount = TCL_INDEX_NONE; /* i.e., unused */ lPtr->nextPtr = NULL; if (litPtrPtr) { @@ -854,7 +854,7 @@ TclReleaseLiteral( * literal table entry (decrement the ref count of the object). */ - if ((entryPtr->refCount != (unsigned)-1) && (entryPtr->refCount-- <= 1)) { + if ((entryPtr->refCount != TCL_INDEX_NONE) && (entryPtr->refCount-- <= 1)) { if (prevPtr == NULL) { globalTablePtr->buckets[index] = entryPtr->nextPtr; } else { @@ -1183,7 +1183,7 @@ TclVerifyLocalLiteralTable( for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL; localPtr=localPtr->nextPtr) { count++; - if (localPtr->refCount != (unsigned)-1) { + if (localPtr->refCount != TCL_INDEX_NONE) { bytes = TclGetStringFromObj(localPtr->objPtr, &length); Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %u", "TclVerifyLocalLiteralTable", -- cgit v0.12 From a769ee494cca67958b20b1472a4d61b8d5e8a0fb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Jun 2022 07:12:32 +0000 Subject: Put back seemingly useless typedefs (yes, there are picky compilers) --- generic/tcl.h | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/generic/tcl.h b/generic/tcl.h index 94c236a..3b9d483 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -578,6 +578,14 @@ typedef struct Tcl_RegExpInfo { } Tcl_RegExpInfo; /* + * Picky compilers complain if this typdef doesn't appear before the struct's + * reference in tclDecls.h. + */ + +typedef Tcl_StatBuf *Tcl_Stat_; +typedef struct stat *Tcl_OldStat_; + +/* *---------------------------------------------------------------------------- * When a TCL command returns, the interpreter contains a result from the * command. Programmers are strongly encouraged to use one of the functions -- cgit v0.12 From 9c5e4541411287c33ae6727b22ec18fec6cd04fa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Jun 2022 10:41:14 +0000 Subject: Don't use TCL_HASH_TYPE for epoch/refCount type variables, keep it the same as it was in Tcl 8.6 --- generic/tclBasic.c | 2 +- generic/tclCompile.h | 6 +++--- generic/tclEnsemble.c | 2 +- generic/tclInt.h | 36 ++++++++++++++++++------------------ generic/tclObj.c | 4 ++-- generic/tclUtil.c | 2 +- generic/tclVar.c | 6 ++---- 7 files changed, 28 insertions(+), 30 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a78a768..5f32e7d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5274,7 +5274,7 @@ TEOV_RunEnterTraces( { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - unsigned int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; int length, traceCode = TCL_OK; const char *command = TclGetStringFromObj(commandPtr, &length); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 1f40d46..c7c17f3 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -417,7 +417,7 @@ typedef struct ByteCode { * procs are specific to an interpreter so the * code emitted will depend on the * interpreter. */ - TCL_HASH_TYPE compileEpoch; /* Value of iPtr->compileEpoch when this + int compileEpoch; /* Value of iPtr->compileEpoch when this * ByteCode was compiled. Used to invalidate * code when, e.g., commands with compile * procs are redefined. */ @@ -425,11 +425,11 @@ typedef struct ByteCode { * compiled. If the code is executed if a * different namespace, it must be * recompiled. */ - TCL_HASH_TYPE nsEpoch; /* Value of nsPtr->resolverEpoch when this + int nsEpoch; /* Value of nsPtr->resolverEpoch when this * ByteCode was compiled. Used to invalidate * code when new namespace resolution rules * are put into effect. */ - TCL_HASH_TYPE refCount; /* Reference count: set 1 when created plus 1 + int refCount; /* Reference count: set 1 when created plus 1 * for each execution of the code currently * active. This structure can be freed when * refCount becomes zero. */ diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 6c82c6a..5c30a0b 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -105,7 +105,7 @@ static const Tcl_ObjType ensembleCmdType = { */ typedef struct { - unsigned int epoch; /* Used to confirm when the data in this + int epoch; /* Used to confirm when the data in this * really structure matches up with the * ensemble. */ Command *token; /* Reference to the command for which this diff --git a/generic/tclInt.h b/generic/tclInt.h index f5628f7..1a504f4 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -298,7 +298,7 @@ typedef struct Namespace { * frames for this namespace that are on the * Tcl call stack. The namespace won't be * freed until activationCount becomes zero. */ - TCL_HASH_TYPE refCount; /* Count of references by namespaceName + int refCount; /* Count of references by namespaceName * objects. The namespace can't be freed until * refCount becomes zero. */ Tcl_HashTable cmdTable; /* Contains all the commands currently @@ -323,12 +323,12 @@ typedef struct Namespace { * registered using "namespace export". */ int maxExportPatterns; /* Mumber of export patterns for which space * is currently allocated. */ - TCL_HASH_TYPE cmdRefEpoch; /* Incremented if a newly added command + int cmdRefEpoch; /* Incremented if a newly added command * shadows a command for which this namespace * has already cached a Command* pointer; this * causes all its cached Command* pointers to * be invalidated. */ - TCL_HASH_TYPE resolverEpoch; /* Incremented whenever (a) the name + int resolverEpoch; /* Incremented whenever (a) the name * resolution rules change for this namespace * or (b) a newly added command shadows a * command that is compiled to bytecodes. This @@ -355,7 +355,7 @@ typedef struct Namespace { * LookupCompiledLocal to resolve variable * references within the namespace at compile * time. */ - TCL_HASH_TYPE exportLookupEpoch; /* Incremented whenever a command is added to + int exportLookupEpoch; /* Incremented whenever a command is added to * a namespace, removed from a namespace or * the exports of a namespace are changed. * Allows TIP#112-driven command lists to be @@ -455,7 +455,7 @@ typedef struct EnsembleConfig { * if the command has been deleted (or never * existed; the global namespace never has an * ensemble command.) */ - TCL_HASH_TYPE epoch; /* The epoch at which this ensemble's table of + int epoch; /* The epoch at which this ensemble's table of * exported commands is valid. */ char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all * consistent points, this will have the same @@ -568,7 +568,7 @@ typedef struct CommandTrace { struct CommandTrace *nextPtr; /* Next in list of traces associated with a * particular command. */ - TCL_HASH_TYPE refCount; /* Used to ensure this structure is not + int refCount; /* Used to ensure this structure is not * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ @@ -641,7 +641,7 @@ typedef struct Var { typedef struct VarInHash { Var var; - TCL_HASH_TYPE refCount; /* Counts number of active uses of this + int refCount; /* Counts number of active uses of this * variable: 1 for the entry in the hash * table, 1 for each additional variable whose * linkPtr points here, 1 for each nested @@ -978,7 +978,7 @@ typedef struct CompiledLocal { typedef struct Proc { struct Interp *iPtr; /* Interpreter for which this command is * defined. */ - TCL_HASH_TYPE refCount; /* Reference count: 1 if still present in + int refCount; /* Reference count: 1 if still present in * command table plus 1 for each call to the * procedure that is currently active. This * structure can be freed when refCount @@ -1095,7 +1095,7 @@ typedef struct AssocData { */ typedef struct LocalCache { - TCL_HASH_TYPE refCount; + int refCount; int numVars; Tcl_Obj *varName0; } LocalCache; @@ -1261,7 +1261,7 @@ typedef struct CmdFrame { typedef struct CFWord { CmdFrame *framePtr; /* CmdFrame to access. */ int word; /* Index of the word in the command. */ - TCL_HASH_TYPE refCount; /* Number of times the word is on the + int refCount; /* Number of times the word is on the * stack. */ } CFWord; @@ -1529,7 +1529,7 @@ typedef struct LiteralEntry { * NULL if end of chain. */ Tcl_Obj *objPtr; /* Points to Tcl object that holds the * literal's bytes and length. */ - int refCount; /* If in an interpreter's global literal + int refCount; /* If in an interpreter's global literal * table, the number of ByteCode structures * that share the literal object; the literal * entry can be freed when refCount drops to @@ -1671,12 +1671,12 @@ typedef struct Command { * recreated). */ Namespace *nsPtr; /* Points to the namespace containing this * command. */ - TCL_HASH_TYPE refCount; /* 1 if in command hashtable plus 1 for each + int refCount; /* 1 if in command hashtable plus 1 for each * reference from a CmdName Tcl object * representing a command's name in a ByteCode * instruction sequence. This structure can be * freed when refCount becomes zero. */ - TCL_HASH_TYPE cmdEpoch; /* Incremented to invalidate any references + int cmdEpoch; /* Incremented to invalidate any references * that point to this command when it is * renamed, deleted, hidden, or exposed. */ CompileProc *compileProc; /* Procedure called to compile command. NULL @@ -1728,6 +1728,7 @@ typedef struct Command { */ #define CMD_DYING 0x01 +#define CMD_IS_DELETED 0x01 /* Same as CMD_DYING (Deprecated) */ #define CMD_TRACE_ACTIVE 0x02 #define CMD_HAS_EXEC_TRACES 0x04 #define CMD_COMPILES_EXPANDED 0x08 @@ -1942,7 +1943,7 @@ typedef struct Interp { * compiled by the interpreter. Indexed by the * string representations of literals. Used to * avoid creating duplicate objects. */ - TCL_HASH_TYPE compileEpoch; /* Holds the current "compilation epoch" for + int compileEpoch; /* Holds the current "compilation epoch" for * this interpreter. This is incremented to * invalidate existing ByteCodes when, e.g., a * command with a compile procedure is @@ -2432,7 +2433,7 @@ typedef enum TclEolTranslation { */ typedef struct List { - TCL_HASH_TYPE refCount; + int refCount; int maxElemCount; /* Total number of element array slots. */ int elemCount; /* Current number of list elements. */ int canonicalFlag; /* Set if the string representation was @@ -2668,7 +2669,7 @@ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, TCL_HASH_TYPE *len */ typedef struct ProcessGlobalValue { - TCL_HASH_TYPE epoch; /* Epoch counter to detect changes in the + int epoch; /* Epoch counter to detect changes in the * global value. */ TCL_HASH_TYPE numBytes; /* Length of the global string. */ char *value; /* The global string value. */ @@ -3018,8 +3019,7 @@ MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs(Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, - ClientData clientData, - Tcl_CmdDeleteProc *deleteProc); + void *clientData, Tcl_CmdDeleteProc *deleteProc); MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *encodingName); MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle); diff --git a/generic/tclObj.c b/generic/tclObj.c index 8849992..5726596 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -341,12 +341,12 @@ typedef struct ResolvedCmdName { * it's possible that the cmd's containing * namespace was deleted and a new one created * at the same address). */ - unsigned int refNsCmdEpoch; /* Value of the referencing namespace's + int refNsCmdEpoch; /* Value of the referencing namespace's * cmdRefEpoch when the pointer was cached. * Before using the cached pointer, we check * if the namespace's epoch was incremented; * if so, this cached pointer is invalid. */ - unsigned int cmdEpoch; /* Value of the command's cmdEpoch when this + int cmdEpoch; /* Value of the command's cmdEpoch when this * pointer was cached. Before using the cached * pointer, we check if the cmd's epoch was * incremented; if so, the cmd was renamed, diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 2a2f72d..7ab6eae 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4366,7 +4366,7 @@ TclGetProcessGlobalValue( Tcl_Obj *value = NULL; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; - unsigned int epoch = pgvPtr->epoch; + int epoch = pgvPtr->epoch; if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); diff --git a/generic/tclVar.c b/generic/tclVar.c index 0ab2c55..2ef51b2 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -381,8 +381,7 @@ CleanupVar( { if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr) && !TclIsVarTraced(varPtr) - && (VarHashRefCount(varPtr) == (unsigned) - !TclIsVarDeadHash(varPtr))) { + && (VarHashRefCount(varPtr) == !TclIsVarDeadHash(varPtr))) { if (VarHashRefCount(varPtr) == 0) { ckfree(varPtr); } else { @@ -391,8 +390,7 @@ CleanupVar( } if (arrayPtr != NULL && TclIsVarUndefined(arrayPtr) && TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) && - (VarHashRefCount(arrayPtr) == (unsigned) - !TclIsVarDeadHash(arrayPtr))) { + (VarHashRefCount(arrayPtr) == !TclIsVarDeadHash(arrayPtr))) { if (VarHashRefCount(arrayPtr) == 0) { ckfree(arrayPtr); } else { -- cgit v0.12 From 1a619a80d9b1d41d4530a41f827a51d04c37f1ad Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Jun 2022 11:40:47 +0000 Subject: Fix for commit [c8bd577a119f2259], which is (slightly) wrong: allowed space should be between '#' and 'define' --- tools/tcltk-man2html.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index b3433cc..e6d9375 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -43,7 +43,7 @@ proc getversion {tclh {name {}}} { # highlighting straight in some editors if {[regexp -lineanchor \ [string map [list @name@ $name] \ - {^\s*#define\s+@name@_VERSION\s+\"([^.])+\.([^.\"]+)}] \ + {^#\s*define\s+@name@_VERSION\s+\"([^.])+\.([^.\"]+)}] \ $data -> major minor]} { return [list $major $minor] } -- cgit v0.12 From 9ed525256bd289a96f4960aa566f811a5d529ae9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Jun 2022 13:48:19 +0000 Subject: Resolve the TODO: What's going on here? Document or eliminate. Eliminate usage of TCL_MAJOR_VERSION. Allow tcl.h to be used when compiling with -DTCL_MAJOR_VERSION=8 --- generic/tcl.h | 5 +++++ generic/tclBinary.c | 6 +----- generic/tclInt.h | 16 +++++++--------- 3 files changed, 13 insertions(+), 14 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 3b9d483..285c1f5 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -47,7 +47,12 @@ extern "C" { * unix/tcl.spec (1 LOC patch) */ +#if !defined(TCL_MAJOR_VERSION) #define TCL_MAJOR_VERSION 8 +#endif +#if TCL_MAJOR_VERSION != 8 +#error "This header-file is for Tcl 8 only" +#endif #define TCL_MINOR_VERSION 7 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE #define TCL_RELEASE_SERIAL 6 diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 5678a66..bf40924 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -556,12 +556,8 @@ TclGetByteArrayFromObj( baPtr = GET_BYTEARRAY(irPtr); if (numBytesPtr != NULL) { -#if TCL_MAJOR_VERSION > 8 - *numBytesPtr = baPtr->used; -#else - /* TODO: What's going on here? Document or eliminate. */ + /* Make sure we return a value between 0 and UINT_MAX-1, or (size_t)-1 */ *numBytesPtr = ((size_t)(unsigned int)(baPtr->used + 1)) - 1; -#endif } return baPtr->bytes; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 1a504f4..ee3dbf8 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1901,7 +1901,7 @@ typedef struct Interp { * See Tcl_AppendResult code for details. */ -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) char *appendResult; /* Storage space for results generated by * Tcl_AppendResult. Ckalloc-ed. NULL means * not yet allocated. */ @@ -1975,13 +1975,11 @@ typedef struct Interp { * string. Returned by Tcl_ObjSetVar2 when * variable traces change a variable in a * gross way. */ -#if TCL_MAJOR_VERSION < 9 -# if !defined(TCL_NO_DEPRECATED) +#if !defined(TCL_NO_DEPRECATED) char resultSpace[TCL_DSTRING_STATIC_SIZE+1]; /* Static space holding small results. */ -# else +#else char resultSpaceDontUse[TCL_DSTRING_STATIC_SIZE+1]; -# endif #endif Tcl_Obj *objResultPtr; /* If the last command returned an object * result, this points to it. Should not be @@ -2646,7 +2644,7 @@ typedef Tcl_Channel (TclOpenFileChannelProc_)(Tcl_Interp *interp, *---------------------------------------------------------------- */ -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) typedef Tcl_CmdProc *TclCmdProcType; typedef Tcl_ObjCmdProc *TclObjCmdProcType; #endif @@ -2717,7 +2715,7 @@ typedef struct ProcessGlobalValue { */ #define TCL_NUMBER_INT 2 -#if (TCL_MAJOR_VERSION < 9) && !defined(TCL_NO_DEPRECATED) +#if !defined(TCL_NO_DEPRECATED) # define TCL_NUMBER_LONG 1 /* deprecated, not used any more */ # define TCL_NUMBER_WIDE TCL_NUMBER_INT /* deprecated */ #endif @@ -3380,7 +3378,7 @@ MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -4586,7 +4584,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, (objPtr)->typePtr = NULL; \ } -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 8 +#if !defined(TCL_NO_DEPRECATED) # define TclFreeIntRep(objPtr) TclFreeInternalRep(objPtr) #endif -- cgit v0.12 From 0ea8daaec8aab6fdebacaf71b35869d1e810bffa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Jun 2022 14:26:14 +0000 Subject: slightly stricter checking for TCL_MAJOR_VERSION in rules.vc --- win/rules.vc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/rules.vc b/win/rules.vc index 47c0742..db65ce7 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -693,7 +693,7 @@ LINKERFLAGS = $(LINKERFLAGS) -ltcg !if [echo REM = This file is generated from rules.vc > versions.vc] !endif !if [echo TCL_MAJOR_VERSION = \>> versions.vc] \ - && [nmakehlp -V "$(_TCL_H)" TCL_MAJOR_VERSION >> versions.vc] + && [nmakehlp -V "$(_TCL_H)" "define TCL_MAJOR_VERSION" >> versions.vc] !endif !if [echo TCL_MINOR_VERSION = \>> versions.vc] \ && [nmakehlp -V "$(_TCL_H)" TCL_MINOR_VERSION >> versions.vc] -- cgit v0.12 From 17e23452bfe9efb1a43b841b47af20b29e53d788 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Jun 2022 20:02:06 +0000 Subject: typo's --- generic/tclExecute.c | 2 +- generic/tclOO.h | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 739641b..25b9409 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -73,7 +73,7 @@ int tclTraceExec = 0; * expression opcodes (e.g., INST_LOR) in tclCompile.h. * * Does not include the string for INST_EXPON (and beyond), as that is - * disjoint for backward-compatability reasons. + * disjoint for backward-compatibility reasons. */ static const char *const operatorStrings[] = { diff --git a/generic/tclOO.h b/generic/tclOO.h index 32afbf1..a5c67b3 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -95,7 +95,7 @@ typedef struct { /* * 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. + * binary compatibility. */ #define TCL_OO_METHOD_VERSION_CURRENT 1 @@ -122,7 +122,7 @@ typedef struct { /* * The correct value for the version field of the Tcl_ObjectMetadataType * structure. This allows new versions of the structure to be introduced - * without breaking binary compatability. + * without breaking binary compatibility. */ #define TCL_OO_METADATA_VERSION_CURRENT 1 -- cgit v0.12 From 0472b619fbc768a10d329b4a3b23ea32370a8d7e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 28 Jun 2022 09:38:00 +0000 Subject: typo's --- unix/dltest/pkgooa.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c index 8dea0aa..9f78da8 100644 --- a/unix/dltest/pkgooa.c +++ b/unix/dltest/pkgooa.c @@ -109,7 +109,7 @@ Pkgooa_Init( return TCL_ERROR; } if (tclStubsPtr == NULL) { - Tcl_AppendResult(interp, "Tcl stubs are not inialized, " + Tcl_AppendResult(interp, "Tcl stubs are not initialized, " "did you compile using -DUSE_TCL_STUBS? "); return TCL_ERROR; } @@ -117,11 +117,11 @@ Pkgooa_Init( return TCL_ERROR; } if (tclOOStubsPtr == NULL) { - Tcl_AppendResult(interp, "TclOO stubs are not inialized"); + Tcl_AppendResult(interp, "TclOO stubs are not initialized"); return TCL_ERROR; } if (tclOOIntStubsPtr == NULL) { - Tcl_AppendResult(interp, "TclOO internal stubs are not inialized"); + Tcl_AppendResult(interp, "TclOO internal stubs are not initialized"); return TCL_ERROR; } -- cgit v0.12 From 83253ae734a523f4c548f386cc890d065d6d3d1e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 30 Jun 2022 11:31:15 +0000 Subject: Fix [b79df322a9]: Tcl_NewUnicodeObj truncates strings --- generic/tclStringObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 13d91d9..86b3937 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -564,7 +564,7 @@ Tcl_NewUnicodeObj( String *stringPtr = (String *)ckalloc((offsetof(String, unicode) + sizeof(unsigned short)) + numChars * sizeof(unsigned short)); - memcpy(stringPtr->unicode, unicode, numChars); + memcpy(stringPtr->unicode, unicode, numChars * sizeof(unsigned short)); stringPtr->unicode[numChars] = 0; stringPtr->numChars = numChars; -- cgit v0.12 From 29ac91cbfe043b243eb5e67530bd1ec5b22b4f40 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 1 Jul 2022 15:14:15 +0000 Subject: Test for TclOO 1.1.0. Remove some useless type-casts --- generic/tclBasic.c | 2 +- generic/tclOO.c | 4 ++-- tests/oo.test | 2 +- tests/ooNext2.test | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 33a96eb..9243539 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4577,7 +4577,7 @@ TEOV_PushExceptionHandlers( */ TclNRAddCallback(interp, TEOV_Error, INT2PTR(objc), - (ClientData) objv, NULL, NULL); + objv, NULL, NULL); } if (iPtr->numLevels == 1) { diff --git a/generic/tclOO.c b/generic/tclOO.c index 9a32543..043aa4c 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -136,7 +136,7 @@ static const Tcl_MethodType classConstructor = { * file). */ -static const char *initScript = +static const char initScript[] = "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};" "namespace eval ::oo { variable version " TCLOO_VERSION " };" "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; @@ -276,7 +276,7 @@ TclOOInit( } return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL, - (ClientData) &tclOOStubs); + &tclOOStubs); } /* diff --git a/tests/oo.test b/tests/oo.test index 0f58c5d..abd5d31 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 TclOO 1.0.3 +package require TclOO 1.1.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 0ec7cdd..74ba006 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 TclOO 1.0.3 +package require TclOO 1.1.0 if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* -- cgit v0.12 From 4d0bc87fb41014bd1ca72ebc565ac4d6b8230bd4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 4 Jul 2022 08:31:08 +0000 Subject: Add TCL_COMBINE, just a NOP for now (will get a meaning in 9.0 --- generic/tcl.h | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/generic/tcl.h b/generic/tcl.h index d53c0f2..d99e9fa 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -993,6 +993,13 @@ typedef struct Tcl_DString { #define TCL_INDEX_TEMP_TABLE 64 /* + * Flags that may be passed to Tcl_UniCharToUtf. + * TCL_COMBINE Combine surrogates (default in Tcl 8.x) + */ + +#define TCL_COMBINE 0 + +/* *---------------------------------------------------------------------------- * Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv. * WARNING: these bit choices must not conflict with the bit choices for -- cgit v0.12 From 62f9be3bc246d8af459066978a4ee75d0ff10d88 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 4 Jul 2022 11:30:20 +0000 Subject: Some -1 -> TCL_INDEX_NONE (Thanks, Gustaf!) --- generic/tclCompile.h | 8 ++++---- generic/tclDecls.h | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclCompile.h b/generic/tclCompile.h index c7c17f3..b3f1c78 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -97,7 +97,7 @@ typedef struct ExceptionRange { int numCodeBytes; /* Number of bytes in the code range. */ int breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC * offset for a break command in the range. */ - int continueOffset; /* If LOOP_EXCEPTION_RANGE and not -1, the + int continueOffset; /* If LOOP_EXCEPTION_RANGE and not TCL_INDEX_NONE, the * target PC offset for a continue command in * the code range. Otherwise, ignore this * range when processing a continue @@ -297,9 +297,9 @@ typedef struct CompileEnv { * information provided by ObjInterpProc in * tclProc.c. */ int numCommands; /* Number of commands compiled. */ - int exceptDepth; /* Current exception range nesting level; -1 + int exceptDepth; /* Current exception range nesting level; TCL_INDEX_NONE * if not in any range currently. */ - int maxExceptDepth; /* Max nesting level of exception ranges; -1 + int maxExceptDepth; /* Max nesting level of exception ranges; TCL_INDEX_NONE * if no ranges have been compiled. */ int maxStackDepth; /* Maximum number of stack elements needed to * execute the code. Set by compilation @@ -458,7 +458,7 @@ typedef struct ByteCode { int numCmdLocBytes; /* Number of bytes needed for encoded command * location information. */ int maxExceptDepth; /* Maximum nesting level of ExceptionRanges; - * -1 if no ranges were compiled. */ + * TCL_INDEX_NONE if no ranges were compiled. */ int maxStackDepth; /* Maximum number of stack elements needed to * execute the code. */ unsigned char *codeStart; /* Points to the first byte of the code. This diff --git a/generic/tclDecls.h b/generic/tclDecls.h index bf79fa6..a53f25d 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4150,7 +4150,7 @@ extern const TclStubs *tclStubsPtr; Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags) #undef Tcl_AddErrorInfo #define Tcl_AddErrorInfo(interp, message) \ - Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, -1)) + Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, TCL_INDEX_NONE)) #undef Tcl_AddObjErrorInfo #define Tcl_AddObjErrorInfo(interp, message, length) \ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length)) @@ -4173,10 +4173,10 @@ extern const TclStubs *tclStubsPtr; #define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp)) #undef Tcl_Eval #define Tcl_Eval(interp, objPtr) \ - Tcl_EvalEx(interp, objPtr, -1, 0) + Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, 0) #undef Tcl_GlobalEval #define Tcl_GlobalEval(interp, objPtr) \ - Tcl_EvalEx(interp, objPtr, -1, TCL_EVAL_GLOBAL) + Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, TCL_EVAL_GLOBAL) #undef Tcl_SaveResult #define Tcl_SaveResult(interp, statePtr) \ do { \ @@ -4199,7 +4199,7 @@ extern const TclStubs *tclStubsPtr; do { \ const char *__result = result; \ Tcl_FreeProc *__freeProc = freeProc; \ - Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, -1)); \ + Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, TCL_INDEX_NONE)); \ if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \ if (__freeProc == TCL_DYNAMIC) { \ ckfree((char *)__result); \ -- cgit v0.12