From f2e08d25dbc3a64b9197ac4477e972d6109cf11b Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 26 Apr 2021 22:48:15 +0000 Subject: Add test constaints "debug", "purify", and "debugpurify" --- generic/tclTest.c | 74 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/tcltests.tcl | 10 ++++++++ 2 files changed, 84 insertions(+) diff --git a/generic/tclTest.c b/generic/tclTest.c index 39bd392..99fe92f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -227,6 +227,7 @@ static Tcl_CmdProc TestcreatecommandCmd; static Tcl_CmdProc TestdcallCmd; static Tcl_CmdProc TestdelCmd; static Tcl_CmdProc TestdelassocdataCmd; +static Tcl_ObjCmdProc TestdebugObjCmd; static Tcl_ObjCmdProc TestdoubledigitsObjCmd; static Tcl_CmdProc TestdstringCmd; static Tcl_ObjCmdProc TestencodingObjCmd; @@ -265,6 +266,7 @@ static Tcl_ObjCmdProc TestparsevarObjCmd; static Tcl_ObjCmdProc TestparsevarnameObjCmd; static Tcl_ObjCmdProc TestpreferstableObjCmd; static Tcl_ObjCmdProc TestprintObjCmd; +static Tcl_ObjCmdProc TestpurifyObjCmd; static Tcl_ObjCmdProc TestregexpObjCmd; static Tcl_ObjCmdProc TestreturnObjCmd; static void TestregexpXflags(const char *string, @@ -504,6 +506,8 @@ Tcltest_Init( Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd, NULL, NULL); Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testdebug", TestdebugObjCmd, + NULL, NULL); Tcl_CreateCommand(interp, "testdel", TestdelCmd, NULL, NULL); Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd, NULL, NULL); @@ -568,6 +572,8 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testpurify", TestpurifyObjCmd, + NULL, NULL); Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd, @@ -3364,6 +3370,40 @@ TestlocaleCmd( /* *---------------------------------------------------------------------- * + * TestdebugObjCmd -- + * + * Implements the "testdebug" command, to detect whether Tcl was built with + * --enabble-symbols. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestdebugObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + TCL_UNUSED(int) /*objc*/, + TCL_UNUSED(Tcl_Obj *const *) /*objv*/) +{ + +#if defined(NDEBUG) && NDEBUG == 1 + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); +#else + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); +#endif + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * CleanupTestSetassocdataTests -- * * This function is called when an interpreter is deleted to clean @@ -3765,6 +3805,40 @@ TestprintObjCmd( /* *---------------------------------------------------------------------- * + * TestpurifyObjCmd -- + * + * Implements the "testpurify" command, to detect whether Tcl was built with + * -DPURIFY. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestpurifyObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + TCL_UNUSED(int) /*objc*/, + TCL_UNUSED(Tcl_Obj *const *) /*objv*/) +{ + +#ifdef PURIFY + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); +#else + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); +#endif + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestregexpObjCmd -- * * This procedure implements the "testregexp" command. It is used to give diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index 193ba0a..09c8b28 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -3,6 +3,16 @@ package require tcltest 2.5 namespace import ::tcltest::* testConstraint exec [llength [info commands exec]] +testConstraint debug [testdebug] +testConstraint purify [testpurify] +testConstraint debugpurify [ + expr { + ![stestConstraint memory] + && + [testConstraint debug] + && + [testConstraint purify] +}] testConstraint fcopy [llength [info commands fcopy]] testConstraint fileevent [llength [info commands fileevent]] testConstraint thread [ -- cgit v0.12 From 28437b46c38ff3c6528d51c7d5e11e35a2d64df4 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 26 Apr 2021 22:53:42 +0000 Subject: Add io-28.6 an io-28.7 to test closing a channel within a channel event handler. --- tests/io.test | 75 +++++++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 70 insertions(+), 5 deletions(-) diff --git a/tests/io.test b/tests/io.test index e0a2389..ddf2403 100644 --- a/tests/io.test +++ b/tests/io.test @@ -2346,9 +2346,9 @@ test io-28.3 {CloseChannel, not called before output queue is empty} \ set result ok } } ok -test io-28.4 {Tcl_Close} {testchannel} { +test io-28.4 Tcl_Close testchannel { file delete $path(test1) - set l "" + set l {} lappend l [lsort [testchannel open]] set f [open $path(test1) w] lappend l [lsort [testchannel open]] @@ -2373,6 +2373,74 @@ test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel} { lsort $l } {file1 file2} + +test io-28.6 { + close channel in write event handler + + Should not produce a segmentation fault in a Tcl built with + --enable-symbols and -DPURIFY +} debugpurify { + variable done + variable res + after 0 [list coroutine c1 apply [list {} { + variable done + set chan [chan create w {apply {args { + list initialize finalize watch write configure blocking + }}}] + chan configure $chan -blocking 0 + while 1 { + chan event $chan writable [list [info coroutine]] + yield + close $chan + set done 1 + return + } + } [namespace current]]] + vwait [namespace current]::done +return success +} success + + +test io-28.7 { + close channel in read event handler + + Should not produce a segmentation fault in a Tcl built with + --enable-symbols and -DPURIFY +} debugpurify { + variable done + variable res + after 0 [list coroutine c1 apply [list {} { + variable done + set chan [chan create r {apply {{cmd chan args} { + switch $cmd { + blocking - finalize { + } + watch { + chan postevent $chan read + } + initialize { + list initialize finalize watch read write configure blocking + } + default { + error [list {unexpected command} $cmd] + } + } + }}}] + chan configure $chan -blocking 0 + while 1 { + chan event $chan readable [list [info coroutine]] + yield + close $chan + set done 1 + return + } + } [namespace current]]] + vwait [namespace current]::done +return success +} success + + + test io-29.1 {Tcl_WriteChars, channel not writable} { list [catch {puts stdin hello} msg] $msg } {1 {channel "stdin" wasn't opened for writing}} @@ -5310,9 +5378,6 @@ test io-39.1 {Tcl_GetChannelOption} { close $f1 set x } 1 -# -# Test 17.2 was removed. -# test io-39.2 {Tcl_GetChannelOption} { file delete $path(test1) set f1 [open $path(test1) w] -- cgit v0.12 From b6d1ba3fdb3cf3af7b1d63e37b2bb3e49c18f84f Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 26 Apr 2021 23:01:03 +0000 Subject: Fix typo in tcltests.tcl. --- tests/tcltests.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index 09c8b28..4dea64f 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -7,7 +7,7 @@ testConstraint debug [testdebug] testConstraint purify [testpurify] testConstraint debugpurify [ expr { - ![stestConstraint memory] + ![testConstraint memory] && [testConstraint debug] && -- cgit v0.12 From 81d499ea3132322afb4b7b97c56a949ad04609ac Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 26 Apr 2021 23:06:14 +0000 Subject: Fix for io-28.6. --- generic/tclIO.c | 40 ++++++++++++++++++++++++---------------- generic/tclIORChan.c | 8 ++++---- 2 files changed, 28 insertions(+), 20 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index fd87520..b9ec2a7 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3660,7 +3660,7 @@ Tcl_CloseEx( * That won't do. */ - if (statePtr->flags & CHANNEL_INCLOSE) { + if (GotFlag(statePtr, CHANNEL_INCLOSE)) { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal recursive call to close through close-handler" @@ -8605,9 +8605,12 @@ ChannelTimerProc( ClientData clientData) { Channel *chanPtr = (Channel *)clientData; + + /* State info for channel */ ChannelState *statePtr = chanPtr->state; - /* State info for channel */ + /* Preserve chanPtr to guard against deallocation in Tcl_NotifyChannel. */ + TclChannelPreserve((Tcl_Channel)chanPtr); Tcl_Preserve(statePtr); statePtr->timer = NULL; if (statePtr->interestMask & TCL_WRITABLE @@ -8623,22 +8626,27 @@ ChannelTimerProc( Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_WRITABLE); } - if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA) - && (statePtr->interestMask & TCL_READABLE) - && (statePtr->inQueueHead != NULL) - && IsBufferReady(statePtr->inQueueHead)) { - /* - * Restart the timer in case a channel handler reenters the event loop - * before UpdateInterest gets called by Tcl_NotifyChannel. - */ + /* The channel may have just been closed from within Tcl_NotifyChannel */ + if (!GotFlag(statePtr, CHANNEL_INCLOSE)) { + if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA) + && (statePtr->interestMask & TCL_READABLE) + && (statePtr->inQueueHead != NULL) + && IsBufferReady(statePtr->inQueueHead)) { + /* + * Restart the timer in case a channel handler reenters the event loop + * before UpdateInterest gets called by Tcl_NotifyChannel. + */ - statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, - ChannelTimerProc,chanPtr); - Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE); - } else { - UpdateInterest(chanPtr); + statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + ChannelTimerProc,chanPtr); + Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE); + } else { + UpdateInterest(chanPtr); + } } + Tcl_Release(statePtr); + TclChannelRelease((Tcl_Channel)chanPtr); } /* @@ -8703,7 +8711,7 @@ Tcl_CreateChannelHandler( /* * The remainder of the initialization below is done regardless of whether - * or not this is a new record or a modification of an old one. + * this is a new record or a modification of an old one. */ chPtr->mask = mask; diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 88f6de8..9097bf4 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -80,7 +80,7 @@ static const Tcl_ChannelType tclRChannelType = { ReflectGetOption, /* Get options. NULL'able */ ReflectWatch, /* Initialize notifier */ NULL, /* Get OS handle from the channel. NULL'able */ - ReflectClose, /* No close2 support. NULL'able */ + ReflectClose, /* No close2 support. NULL'able */ ReflectBlock, /* Set blocking/nonblocking. NULL'able */ NULL, /* Flush channel. Not used by core. NULL'able */ NULL, /* Handle events. NULL'able */ @@ -1156,7 +1156,7 @@ TclChanCaughtErrorBypass( * ReflectClose -- * * This function is invoked when the channel is closed, to delete the - * driver specific instance data. + * driver-specific instance data. * * Results: * A posix error. @@ -1189,8 +1189,8 @@ ReflectClose( /* * This call comes from TclFinalizeIOSystem. There are no * interpreters, and therefore we cannot call upon the handler command - * anymore. Threading is irrelevant as well. We simply clean up all - * our C level data structures and leave the Tcl level to the other + * anymore. Threading is irrelevant as well. Simply clean up all + * the C level data structures and leave the Tcl level to the other * finalization functions. */ -- cgit v0.12 From c7fcbf756c0b7f4332a6d930cfec58945029eacd Mon Sep 17 00:00:00 2001 From: pooryorick Date: Tue, 27 Apr 2021 10:48:58 +0000 Subject: Make tcltests.tcl continue to function even if tclTest.c isn't available. --- tests/tcltests.tcl | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index 4dea64f..1ee37d3 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -3,16 +3,18 @@ package require tcltest 2.5 namespace import ::tcltest::* testConstraint exec [llength [info commands exec]] -testConstraint debug [testdebug] -testConstraint purify [testpurify] -testConstraint debugpurify [ - expr { - ![testConstraint memory] - && - [testConstraint debug] - && - [testConstraint purify] -}] +if {[namespace which testdebug] ne {}} { + testConstraint debug [testdebug] + testConstraint purify [testpurify] + testConstraint debugpurify [ + expr { + ![testConstraint memory] + && + [testConstraint debug] + && + [testConstraint purify] + }] +} testConstraint fcopy [llength [info commands fcopy]] testConstraint fileevent [llength [info commands fileevent]] testConstraint thread [ -- cgit v0.12 From ef9154f1436449e65af48e6356b80877668e349e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 28 Apr 2021 12:42:17 +0000 Subject: Rename TclSetPreInitScript() to Tcl_SetPreInitScript(). Tiny part of TIP #596, the only part meant for 8.7. --- doc/Init.3 | 14 +++++++++++++- generic/tcl.h | 1 + generic/tclInt.decls | 4 ++-- generic/tclIntDecls.h | 10 ++++++---- generic/tclInterp.c | 6 +++--- 5 files changed, 25 insertions(+), 10 deletions(-) diff --git a/doc/Init.3 b/doc/Init.3 index d9fc2e1..cf17a37 100644 --- a/doc/Init.3 +++ b/doc/Init.3 @@ -2,7 +2,7 @@ '\" Copyright (c) 1998-2000 Scriptics Corporation. '\" All rights reserved. '\" -.TH Tcl_Init 3 8.0 Tcl "Tcl Library Procedures" +.TH Tcl_Init 3 8.7 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME @@ -13,10 +13,15 @@ Tcl_Init \- find and source initialization script .sp int \fBTcl_Init\fR(\fIinterp\fR) +.sp +const char * +\fBTcl_SetPreInitScript\fR(\fIscriptPtr\fR) .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Interpreter to initialize. +.AP "const char" *scriptPtr in +Address of the initialization script. .BE .SH DESCRIPTION @@ -26,6 +31,13 @@ Interpreter to initialize. path. .PP \fBTcl_Init\fR is typically called from \fBTcl_AppInit\fR procedures. +.PP +\fBTcl_SetPreInitScript\fR registers the pre-initialization script and +returns the former (now replaced) script pointer. +A value of \fINULL\fR may be passed to not register any script. +The pre-initialization script is executed by \fBTcl_Init\fR before accessing +the file system. The purpose is to typically prepare a custom file system +(like an embedded zip-file) to be activated before the search. .SH "SEE ALSO" Tcl_AppInit, Tcl_Main diff --git a/generic/tcl.h b/generic/tcl.h index 507342f..4d4e2b7 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2385,6 +2385,7 @@ EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact); EXTERN void Tcl_InitSubsystems(void); EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); +EXTERN CONST86 char *Tcl_SetPreInitScript(const char *string); #ifndef TCL_NO_DEPRECATED # define Tcl_StaticPackage Tcl_StaticLibrary #endif diff --git a/generic/tclInt.decls b/generic/tclInt.decls index c7ead64..aad7db3 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -184,7 +184,7 @@ declare 41 { Tcl_Command TclGetOriginalCommand(Tcl_Command command) } declare 42 { - CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) + const char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } # Removed in 8.5a2: #declare 43 { @@ -409,7 +409,7 @@ declare 98 { # Tcl_Obj *objPtr, int flags) #} declare 101 { - CONST86 char *TclSetPreInitScript(const char *string) + const char *TclSetPreInitScript(const char *string) } declare 102 { void TclSetupEnv(Tcl_Interp *interp) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index bfd3102..5ae92e4 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -153,7 +153,7 @@ EXTERN int TclGetOpenMode(Tcl_Interp *interp, const char *str, /* 41 */ EXTERN Tcl_Command TclGetOriginalCommand(Tcl_Command command); /* 42 */ -EXTERN CONST86 char * TclpGetUserHome(const char *name, +EXTERN const char * TclpGetUserHome(const char *name, Tcl_DString *bufferPtr); /* Slot 43 is reserved */ /* 44 */ @@ -264,7 +264,7 @@ EXTERN int TclServiceIdle(void); /* Slot 99 is reserved */ /* Slot 100 is reserved */ /* 101 */ -EXTERN CONST86 char * TclSetPreInitScript(const char *string); +EXTERN const char * TclSetPreInitScript(const char *string); /* 102 */ EXTERN void TclSetupEnv(Tcl_Interp *interp); /* 103 */ @@ -710,7 +710,7 @@ typedef struct TclIntStubs { TclObjCmdProcType (*tclGetObjInterpProc) (void); /* 39 */ int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */ Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */ - CONST86 char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */ + const char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */ void (*reserved43)(void); int (*tclGuessPackageName) (const char *fileName, Tcl_DString *bufPtr); /* 44 */ int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */ @@ -769,7 +769,7 @@ typedef struct TclIntStubs { int (*tclServiceIdle) (void); /* 98 */ void (*reserved99)(void); void (*reserved100)(void); - CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */ + const char * (*tclSetPreInitScript) (const char *string); /* 101 */ void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */ int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */ TCL_DEPRECATED_API("") int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ @@ -1415,7 +1415,9 @@ extern const TclIntStubs *tclIntStubsPtr; #undef TclGuessPackageName #undef TclUnusedStubEntry +#undef TclSetPreInitScript #ifndef TCL_NO_DEPRECATED +# define TclSetPreInitScript Tcl_SetPreInitScript # define TclGuessPackageName(fileName, pkgName) ((void)fileName,(void)pkgName,0) #endif diff --git a/generic/tclInterp.c b/generic/tclInterp.c index d63add2..fd90abc 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -281,7 +281,7 @@ static Tcl_ObjCmdProc NRChildCmd; /* *---------------------------------------------------------------------- * - * TclSetPreInitScript -- + * Tcl_SetPreInitScript -- * * This routine is used to change the value of the internal variable, * tclPreInitScript. @@ -296,12 +296,12 @@ static Tcl_ObjCmdProc NRChildCmd; */ const char * -TclSetPreInitScript( +Tcl_SetPreInitScript( const char *string) /* Pointer to a script. */ { const char *prevString = tclPreInitScript; tclPreInitScript = string; - return(prevString); + return prevString; } /* -- cgit v0.12