From ad53d45452569292a42e5c120a2da8f32d7fdb7c Mon Sep 17 00:00:00 2001 From: culler Date: Sat, 6 Jun 2020 21:23:50 +0000 Subject: Address macOS hangs in Tcl_WaitForEvent. --- macosx/tclMacOSXNotify.c | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index 9b7bd1a..21d95e5 100644 --- a/macosx/tclMacOSXNotify.c +++ b/macosx/tclMacOSXNotify.c @@ -1243,6 +1243,13 @@ Tcl_WaitForEvent( */ polling = 1; + + /* + * Set a small positive waitTime so that when the runloop is started + * it will process all of its sources. + */ + + waitTime = 0.005; } } @@ -1264,11 +1271,16 @@ Tcl_WaitForEvent( runLoopRunning = tsdPtr->runLoopRunning; tsdPtr->runLoopRunning = 1; - runLoopStatus = CFRunLoopRunInMode(tsdPtr->runLoopServicingEvents || - runLoopRunning ? tclEventsOnlyRunLoopMode : kCFRunLoopDefaultMode, - waitTime, TRUE); + runLoopStatus = CFRunLoopRunInMode( + tsdPtr->runLoopServicingEvents || runLoopRunning ? + tclEventsOnlyRunLoopMode : kCFRunLoopDefaultMode, + waitTime, TRUE); tsdPtr->runLoopRunning = runLoopRunning; + if (polling) { + return tsdPtr->runLoopSourcePerformed ? 0 : 1; + } + LOCK_NOTIFIER_TSD; tsdPtr->polling = 0; UNLOCK_NOTIFIER_TSD; @@ -1384,7 +1396,6 @@ UpdateWaitingListAndServiceEvents( void *info) { ThreadSpecificData *tsdPtr = info; - if (tsdPtr->sleeping) { return; } @@ -1407,16 +1418,6 @@ UpdateWaitingListAndServiceEvents( } tsdPtr->runLoopNestingLevel--; break; - case kCFRunLoopBeforeWaiting: - if (tsdPtr->runLoopTimer && !tsdPtr->runLoopServicingEvents && - (tsdPtr->runLoopNestingLevel > 1 - || !tsdPtr->runLoopRunning)) { - tsdPtr->runLoopServicingEvents = 1; - /* This call seems to simply force event processing through and prevents hangups that have long been observed with Tk-Cocoa. */ - Tcl_ServiceAll(); - tsdPtr->runLoopServicingEvents = 0; - } - break; default: break; } -- cgit v0.12 From b345d9a593684ec1fd404884947fa1b5298d1af9 Mon Sep 17 00:00:00 2001 From: culler Date: Sun, 7 Jun 2020 22:15:28 +0000 Subject: Code simplification and cleanup --- macosx/tclMacOSXNotify.c | 41 ++++++++++++++++------------------------- 1 file changed, 16 insertions(+), 25 deletions(-) diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index 21d95e5..6f27e64 100644 --- a/macosx/tclMacOSXNotify.c +++ b/macosx/tclMacOSXNotify.c @@ -494,7 +494,7 @@ Tcl_InitNotifier(void) bzero(&runLoopObserverContext, sizeof(CFRunLoopObserverContext)); runLoopObserverContext.info = tsdPtr; runLoopObserver = CFRunLoopObserverCreate(NULL, - kCFRunLoopEntry|kCFRunLoopExit|kCFRunLoopBeforeWaiting, TRUE, + kCFRunLoopEntry|kCFRunLoopExit, TRUE, LONG_MIN, UpdateWaitingListAndServiceEvents, &runLoopObserverContext); if (!runLoopObserver) { @@ -512,7 +512,7 @@ Tcl_InitNotifier(void) */ runLoopObserverTcl = CFRunLoopObserverCreate(NULL, - kCFRunLoopEntry|kCFRunLoopExit|kCFRunLoopBeforeWaiting, TRUE, + kCFRunLoopEntry|kCFRunLoopExit, TRUE, LONG_MIN, UpdateWaitingListAndServiceEvents, &runLoopObserverContext); if (!runLoopObserverTcl) { @@ -1222,6 +1222,10 @@ Tcl_WaitForEvent( Tcl_Panic("Tcl_WaitForEvent: Notifier not initialized"); } + /* + * A NULL timePtr means wait forever. + */ + if (timePtr) { Tcl_Time vTime = *timePtr; @@ -1235,26 +1239,18 @@ Tcl_WaitForEvent( tclScaleTimeProcPtr(&vTime, tclTimeClientData); waitTime = vTime.sec + 1.0e-6 * vTime.usec; } else { - /* - * Polling: pretend to wait for files and tell the notifier thread - * what we are doing. The notifier thread makes sure it goes - * through select with its select mask in the same state as ours - * currently is. We block until that happens. - */ - - polling = 1; /* - * Set a small positive waitTime so that when the runloop is started - * it will process all of its sources. + * The max block time was set to 0. */ - waitTime = 0.005; + polling = 1; + waitTime = 0; } } StartNotifierThread(); - + LOCK_NOTIFIER_TSD; tsdPtr->polling = polling; UNLOCK_NOTIFIER_TSD; @@ -1262,25 +1258,20 @@ Tcl_WaitForEvent( /* * If the Tcl runloop is already running (e.g. if Tcl_WaitForEvent was - * called recursively) or is servicing events via the runloop observer, - * re-run it in a custom runloop mode containing only the source for the - * notifier thread, otherwise wakeups from other sources added to the - * common runloop modes might get lost or 3rd party event handlers might - * get called when they do not expect to be. + * called recursively) start a new runloop in a custom runloop mode + * containing only the source for the notifier thread. Otherwise wakeups + * from other sources added to the common runloop mode might get lost or + * 3rd party event handlers might get called when they do not expect to + * be. */ runLoopRunning = tsdPtr->runLoopRunning; tsdPtr->runLoopRunning = 1; runLoopStatus = CFRunLoopRunInMode( - tsdPtr->runLoopServicingEvents || runLoopRunning ? - tclEventsOnlyRunLoopMode : kCFRunLoopDefaultMode, + runLoopRunning ? tclEventsOnlyRunLoopMode : kCFRunLoopDefaultMode, waitTime, TRUE); tsdPtr->runLoopRunning = runLoopRunning; - if (polling) { - return tsdPtr->runLoopSourcePerformed ? 0 : 1; - } - LOCK_NOTIFIER_TSD; tsdPtr->polling = 0; UNLOCK_NOTIFIER_TSD; -- cgit v0.12 From 476d33d6b64feb9beb632647c35619343d3fe732 Mon Sep 17 00:00:00 2001 From: culler Date: Thu, 18 Jun 2020 20:02:01 +0000 Subject: Sometimes the waitTime needs to be positive to avoid missing channel io events. --- macosx/tclMacOSXNotify.c | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index 6f27e64..4ce6786 100644 --- a/macosx/tclMacOSXNotify.c +++ b/macosx/tclMacOSXNotify.c @@ -255,8 +255,6 @@ typedef struct ThreadSpecificData { int runLoopRunning; /* True if this thread's Tcl runLoop is * running. */ int runLoopNestingLevel; /* Level of nested runLoop invocations. */ - int runLoopServicingEvents; /* True if this thread's runLoop is servicing - * Tcl events. */ /* Must hold the notifierLock before accessing the following fields: */ /* Start notifierLock section */ @@ -1225,7 +1223,7 @@ Tcl_WaitForEvent( /* * A NULL timePtr means wait forever. */ - + if (timePtr) { Tcl_Time vTime = *timePtr; @@ -1242,15 +1240,25 @@ Tcl_WaitForEvent( /* * The max block time was set to 0. + * + * If we set the waitTime to 0, then the call to CFRunLoopInMode + * may return without processing all of its sources. The Apple + * documentation says that if the waitTime is 0 "only one pass is + * made through the run loop before returning; if multiple sources + * or timers are ready to fire immediately, only one (possibly two + * if one is a version 0 source) will be fired, regardless of the + * value of returnAfterSourceHandled." This can cause some chanio + * tests to fail. So we use a small positive waitTime unless there + * is another RunLoop running. */ polling = 1; - waitTime = 0; + waitTime = tsdPtr->runLoopRunning ? 0 : 0.0001; } } StartNotifierThread(); - + LOCK_NOTIFIER_TSD; tsdPtr->polling = polling; UNLOCK_NOTIFIER_TSD; -- cgit v0.12 From a0457efe80223c1380e9e0fc6a50c755fc7bbeda Mon Sep 17 00:00:00 2001 From: culler Date: Mon, 22 Jun 2020 16:12:00 +0000 Subject: Use the os_unfair_lock in place of OSSpinLock when the minimum build target is newer than OSX 10.12 --- macosx/tclMacOSXNotify.c | 70 +++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 60 insertions(+), 10 deletions(-) diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index 4ce6786..1f9d0ea 100644 --- a/macosx/tclMacOSXNotify.c +++ b/macosx/tclMacOSXNotify.c @@ -14,6 +14,18 @@ */ #include "tclInt.h" + +/* + * In macOS 10.12 the os_unfair_lock was introduced as a replacement for the + * OSSpinLock, and the OSSpinLock was deprecated. + */ + +#if MAC_OS_X_VERSION_MIN_REQUIRED >= 101200 +#define USE_OS_UNFAIR_LOCK +#include +#undef TCL_MAC_DEBUG_NOTIFIER +#endif + #ifdef HAVE_COREFOUNDATION /* Traditional unix select-based notifier is * in tclUnixNotfy.c */ #include @@ -21,6 +33,8 @@ /* #define TCL_MAC_DEBUG_NOTIFIER 1 */ +#if !defined(USE_OS_UNFAIR_LOCK) + /* * We use the Darwin-native spinlock API rather than pthread mutexes for * notifier locking: this radically simplifies the implementation and lowers @@ -102,26 +116,45 @@ extern int _spin_lock_try(OSSpinLock *lock); #define SPINLOCK_INIT 0 #endif /* HAVE_LIBKERN_OSATOMIC_H && HAVE_OSSPINLOCKLOCK */ +#endif /* not using os_unfair_lock */ /* - * These spinlocks lock access to the global notifier state. + * These locks control access to the global notifier state. */ +#if defined(USE_OS_UNFAIR_LOCK) +static os_unfair_lock notifierInitLock = OS_UNFAIR_LOCK_INIT; +static os_unfair_lock notifierLock = OS_UNFAIR_LOCK_INIT; +#else static OSSpinLock notifierInitLock = SPINLOCK_INIT; static OSSpinLock notifierLock = SPINLOCK_INIT; +#endif /* - * Macros abstracting notifier locking/unlocking + * Macros that abstract notifier locking/unlocking */ +#if defined(USE_OS_UNFAIR_LOCK) +#define LOCK_NOTIFIER_INIT os_unfair_lock_lock(¬ifierInitLock) +#define UNLOCK_NOTIFIER_INIT os_unfair_lock_unlock(¬ifierInitLock) +#define LOCK_NOTIFIER os_unfair_lock_lock(¬ifierLock) +#define UNLOCK_NOTIFIER os_unfair_lock_unlock(¬ifierLock) +#define LOCK_NOTIFIER_TSD os_unfair_lock_lock(&tsdPtr->tsdLock) +#define UNLOCK_NOTIFIER_TSD os_unfair_lock_unlock(&tsdPtr->tsdLock) +#else #define LOCK_NOTIFIER_INIT SpinLockLock(¬ifierInitLock) #define UNLOCK_NOTIFIER_INIT SpinLockUnlock(¬ifierInitLock) #define LOCK_NOTIFIER SpinLockLock(¬ifierLock) #define UNLOCK_NOTIFIER SpinLockUnlock(¬ifierLock) #define LOCK_NOTIFIER_TSD SpinLockLock(&tsdPtr->tsdLock) #define UNLOCK_NOTIFIER_TSD SpinLockUnlock(&tsdPtr->tsdLock) +#endif -#ifdef TCL_MAC_DEBUG_NOTIFIER +/* + * The debug version of the Notifier only works if using OSSpinLock. + */ + +#if defined(TCL_MAC_DEBUG_NOTIFIER) && !defined(USE_OS_UNFAIR_LOCK) #define TclMacOSXNotifierDbgMsg(m, ...) \ do { \ fprintf(notifierLog?notifierLog:stderr, "tclMacOSXNotify.c:%d: " \ @@ -148,7 +181,7 @@ static OSSpinLock notifierLock = SPINLOCK_INIT; #undef LOCK_NOTIFIER #define LOCK_NOTIFIER SpinLockLockDbg(¬ifierLock) #undef LOCK_NOTIFIER_TSD -#define LOCK_NOTIFIER_TSD SpinLockLockDbg(&tsdPtr->tsdLock) +#define LOCK_NOTIFIER_TSD SpinLockLockDbg(tsdPtr->tsdLock) #include static FILE *notifierLog = NULL; #ifndef NOTIFIER_LOG @@ -267,9 +300,14 @@ typedef struct ThreadSpecificData { * from these pointers. */ /* End notifierLock section */ +#if defined(USE_OS_UNFAIR_LOCK) + os_unfair_lock tsdLock; +#else OSSpinLock tsdLock; /* Must hold this lock before acessing the * following fields from more than one * thread. */ +#endif + /* Start tsdLock section */ SelectMasks checkMasks; /* This structure is used to build up the * masks to be used in the next call to @@ -455,7 +493,6 @@ Tcl_InitNotifier(void) /* * Initialize support for weakly imported spinlock API. */ - if (pthread_once(&spinLockLockInitControl, SpinLockLockInit)) { Tcl_Panic("Tcl_InitNotifier: pthread_once failed"); } @@ -526,7 +563,11 @@ Tcl_InitNotifier(void) tsdPtr->runLoopObserverTcl = runLoopObserverTcl; tsdPtr->runLoopTimer = NULL; tsdPtr->waitTime = CF_TIMEINTERVAL_FOREVER; +#if defined(USE_OS_UNFAIR_LOCK) + tsdPtr->tsdLock = OS_UNFAIR_LOCK_INIT; +#else tsdPtr->tsdLock = SPINLOCK_INIT; +#endif } LOCK_NOTIFIER_INIT; @@ -584,7 +625,6 @@ Tcl_InitNotifier(void) ENABLE_ASL; notifierCount++; UNLOCK_NOTIFIER_INIT; - return tsdPtr; } @@ -1449,7 +1489,7 @@ OnOffWaitingList( { int changeWaitingList; -#ifdef TCL_MAC_DEBUG_NOTIFIER +#if defined(TCL_MAC_DEBUG_NOTIFIER) && !defined(USE_OS_UNFAIR_LOCK) if (SpinLockTry(¬ifierLock)) { Tcl_Panic("OnOffWaitingList: notifierLock unlocked"); } @@ -1980,9 +2020,19 @@ AtForkChild(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - UNLOCK_NOTIFIER_TSD; - UNLOCK_NOTIFIER; - UNLOCK_NOTIFIER_INIT; + /* + * If a child process unlocks an os_unfair_lock that was created in its parent + * the child will exit with an illegal instruction error. So we reinitialize + * the lock in the child rather than attempt to unlock it. + */ + +#if defined(USE_OS_UNFAIR_LOCK) + tsdPtr->tsdLock = OS_UNFAIR_LOCK_INIT; +#else + UNLOCK_NOTIFIER_TSD; + UNLOCK_NOTIFIER; + UNLOCK_NOTIFIER_INIT; +#endif if (tsdPtr->runLoop) { tsdPtr->runLoop = NULL; if (!noCFafterFork) { -- cgit v0.12 From 932835c1ebe010e7c12090fc2a09d00170c641ba Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 30 Jun 2020 11:59:48 +0000 Subject: doc/clock.n: clearer form explaininng format groups on output --- doc/clock.n | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/doc/clock.n b/doc/clock.n index 0460a54..b2d53ed 100644 --- a/doc/clock.n +++ b/doc/clock.n @@ -448,36 +448,36 @@ The following format groups are recognized by the \fBclock scan\fR and \fBclock format\fR commands. .TP \fB%a\fR -On output, receives an abbreviation (\fIe.g.,\fR \fBMon\fR) for the day +On output, produces an abbreviation (\fIe.g.,\fR \fBMon\fR) for the day of the week in the given locale. On input, matches the name of the day of the week in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%A\fR -On output, receives the full name (\fIe.g.,\fR \fBMonday\fR) of the day +On output, produces the full name (\fIe.g.,\fR \fBMonday\fR) of the day of the week in the given locale. On input, matches the name of the day of the week in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%b\fR -On output, receives an abbreviation (\fIe.g.,\fR \fBJan\fR) for the name +On output, produces an abbreviation (\fIe.g.,\fR \fBJan\fR) for the name of the month in the given locale. On input, matches the name of the month in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%B\fR -On output, receives the full name (\fIe.g.,\fR \fBJanuary\fR) +On output, produces the full name (\fIe.g.,\fR \fBJanuary\fR) of the month in the given locale. On input, matches the name of the month in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%c\fR -On output, receives a localized representation of date and time of day; +On output, produces a localized representation of date and time of day; the localized representation is expected to use the Gregorian calendar. On input, matches whatever \fB%c\fR produces. .TP \fB%C\fR -On output, receives the number of the century in Indo-Arabic numerals. +On output, produces the number of the century in Indo-Arabic numerals. On input, matches one or two digits, possibly with leading whitespace, that are expected to be the number of the century. .TP -- cgit v0.12 From 565b9dca95a5103374909c089697e655748cc932 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 16 Jul 2020 15:34:57 +0000 Subject: cherry pick [df5f1e8652]: Fix [5bbd044812]: Fix index underflow. --- generic/tclFileName.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclFileName.c b/generic/tclFileName.c index a8360fc..be1fdfa 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -2432,7 +2432,7 @@ DoGlob( int len; const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); - if (strchr(separators, joined[len-1]) == NULL) { + if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) { Tcl_AppendToObj(joinedPtr, "/", 1); } } @@ -2469,7 +2469,7 @@ DoGlob( int len; const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); - if (strchr(separators, joined[len-1]) == NULL) { + if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) { if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) { Tcl_AppendToObj(joinedPtr, "/", 1); } -- cgit v0.12 From 85bdb7cb8e43af0938b1c7f5013daa6b170bd5d4 Mon Sep 17 00:00:00 2001 From: kjnash Date: Thu, 16 Jul 2020 17:29:04 +0000 Subject: Fix error in merging safe.test with safe-bugfixes-8-6 commit d065e8c73d --- tests/safe.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/safe.test b/tests/safe.test index b71a720..e9ec7df 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -583,8 +583,8 @@ test safe-7.2opt {tests specific path and interpFind/AddToAccessPath, uses pkg o [catch {interp eval $i {package require opt}} msg] $msg -- \ $mappA -- [safe::interpDelete $i] } -cleanup { -} -match glob -result {{$p(:0:)} {$p(:*:)} -- 1 {can't find package opt} --\ - {TCLLIB */dummy/unixlike/test/path} -- {}} +} -match glob -result "{\$p(:0:)} {\$p(:*:)} -- 1 {$pkgOptErrMsg} --\ + {TCLLIB */dummy/unixlike/test/path} -- {}" test safe-7.3 {check that safe subinterpreters work} { set g [interp slaves] if {$g ne {}} { -- cgit v0.12 From b4012447b017cbf05b19ee4d45eb25fc3750d75f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 Jul 2020 07:37:30 +0000 Subject: Rename (internal) TclSetSlaveCancelFlags() to TclSetChildCancelFlags(). Follow-up for [e5ea53f27a391285]. --- generic/tclBasic.c | 2 +- generic/tclInt.decls | 2 +- generic/tclIntDecls.h | 8 ++++---- generic/tclInterp.c | 8 ++++---- generic/tclStubInit.c | 2 +- 5 files changed, 11 insertions(+), 11 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 6c14f45..566b980 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3796,7 +3796,7 @@ CancelEvalProc( * interpreters belonging to this one. */ - TclSetSlaveCancelFlags((Tcl_Interp *) iPtr, + TclSetChildCancelFlags((Tcl_Interp *) iPtr, cancelInfo->flags | CANCELED, 0); /* diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 8845359..0addf66 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -990,7 +990,7 @@ declare 249 { } # TIP #285: Script cancellation support. declare 250 { - void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force) + void TclSetChildCancelFlags(Tcl_Interp *interp, int flags, int force) } # Allow extensions for optimization diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 2426326..b698c08 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -623,7 +623,7 @@ EXTERN int TclCopyChannel(Tcl_Interp *interp, EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 250 */ -EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, +EXTERN void TclSetChildCancelFlags(Tcl_Interp *interp, int flags, int force); /* 251 */ EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, @@ -918,7 +918,7 @@ typedef struct TclIntStubs { void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */ int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */ char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ - void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ + void (*tclSetChildCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ int (*tclRegisterLiteral) (void *envPtr, const char *bytes, int length, int flags); /* 251 */ Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 252 */ Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags); /* 253 */ @@ -1356,8 +1356,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclCopyChannel) /* 248 */ #define TclDoubleDigits \ (tclIntStubsPtr->tclDoubleDigits) /* 249 */ -#define TclSetSlaveCancelFlags \ - (tclIntStubsPtr->tclSetSlaveCancelFlags) /* 250 */ +#define TclSetChildCancelFlags \ + (tclIntStubsPtr->tclSetChildCancelFlags) /* 250 */ #define TclRegisterLiteral \ (tclIntStubsPtr->tclRegisterLiteral) /* 251 */ #define TclPtrGetVar \ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 1570837..4addffe 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -2161,7 +2161,7 @@ Tcl_GetMaster( /* *---------------------------------------------------------------------- * - * TclSetSlaveCancelFlags -- + * TclSetChildCancelFlags -- * * This function marks all slave interpreters belonging to a given * interpreter as being canceled or not canceled, depending on the @@ -2177,7 +2177,7 @@ Tcl_GetMaster( */ void -TclSetSlaveCancelFlags( +TclSetChildCancelFlags( Tcl_Interp *interp, /* Set cancel flags of this interpreter. */ int flags, /* Collection of OR-ed bits that control * the cancellation of the script. Only @@ -2220,7 +2220,7 @@ TclSetSlaveCancelFlags( * interpreter. */ - TclSetSlaveCancelFlags((Tcl_Interp *) iPtr, flags, force); + TclSetChildCancelFlags((Tcl_Interp *) iPtr, flags, force); } } @@ -2874,7 +2874,7 @@ SlaveEval( * function for that particular Tcl_Interp. */ - TclSetSlaveCancelFlags(slaveInterp, 0, 0); + TclSetChildCancelFlags(slaveInterp, 0, 0); Tcl_Preserve(slaveInterp); Tcl_AllowExceptions(slaveInterp); diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 2d2bc63..a4645b6 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -974,7 +974,7 @@ static const TclIntStubs tclIntStubs = { TclResetRewriteEnsemble, /* 247 */ TclCopyChannel, /* 248 */ TclDoubleDigits, /* 249 */ - TclSetSlaveCancelFlags, /* 250 */ + TclSetChildCancelFlags, /* 250 */ TclRegisterLiteral, /* 251 */ TclPtrGetVar, /* 252 */ TclPtrSetVar, /* 253 */ -- cgit v0.12 From 56e784cb1b7a6e78689cfa75df0e0dbaf51657d0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 Jul 2020 11:11:47 +0000 Subject: Doc/internal variable tweaks --- doc/CrtAlias.3 | 8 ++++---- generic/tclInterp.c | 10 +++++----- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/doc/CrtAlias.3 b/doc/CrtAlias.3 index 72912bc..82ef122 100644 --- a/doc/CrtAlias.3 +++ b/doc/CrtAlias.3 @@ -158,12 +158,12 @@ If no such slave interpreter exists, \fBNULL\fR is returned. \fIinterp\fR. If \fIinterp\fR has no master (it is a top-level interpreter) then \fBNULL\fR is returned. .PP -\fBTcl_GetInterpPath\fR stores in the result of \fIaskingInterp\fR -the relative path between \fIaskingInterp\fR and \fIslaveInterp\fR; -\fIslaveInterp\fR must be a slave of \fIaskingInterp\fR. If the computation +\fBTcl_GetInterpPath\fR stores in the result of \fIinterp\fR +the relative path between \fIinterp\fR and \fIslaveInterp\fR; +\fIslaveInterp\fR must be a slave of \fIinterp\fR. If the computation of the relative path succeeds, \fBTCL_OK\fR is returned, else \fBTCL_ERROR\fR is returned and an error message is stored as the -result of \fIaskingInterp\fR. +result of \fIinterp\fR. .PP \fBTcl_CreateAlias\fR creates a command named \fIslaveCmd\fR in \fIslaveInterp\fR that when invoked, will cause the command \fItargetCmd\fR diff --git a/generic/tclInterp.c b/generic/tclInterp.c index ac66324..95c68ee 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -2169,23 +2169,23 @@ TclSetSlaveCancelFlags( int Tcl_GetInterpPath( - Tcl_Interp *askingInterp, /* Interpreter to start search from. */ + Tcl_Interp *interp, /* Interpreter to start search from. */ Tcl_Interp *targetInterp) /* Interpreter to find. */ { InterpInfo *iiPtr; - if (targetInterp == askingInterp) { - Tcl_SetObjResult(askingInterp, Tcl_NewObj()); + if (targetInterp == interp) { + Tcl_SetObjResult(interp, Tcl_NewObj()); return TCL_OK; } if (targetInterp == NULL) { return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo; - if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK){ + if (Tcl_GetInterpPath(interp, iiPtr->slave.masterInterp) != TCL_OK){ return TCL_ERROR; } - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(askingInterp), + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), Tcl_NewStringObj(Tcl_GetHashKey(&iiPtr->master.slaveTable, iiPtr->slave.slaveEntryPtr), -1)); return TCL_OK; -- cgit v0.12 From 651f71edfd77b66fd1e585154b7f4390e6df2b6f Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 18 Jul 2020 04:12:08 +0000 Subject: Tidying tests/safe.test --- tests/safe.test | 128 +++++++++++++++++++++++++++++++------------------------- 1 file changed, 70 insertions(+), 58 deletions(-) diff --git a/tests/safe.test b/tests/safe.test index dbcd2cc..2683b9c 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -21,9 +21,8 @@ foreach i [interp slaves] { interp delete $i } -set saveAutoPath $::auto_path +set SaveAutoPath $::auto_path set ::auto_path [info library] - set TestsDir [file normalize [file dirname [info script]]] set PathMapp [list $tcl_library TCLLIB $TestsDir TESTSDIR] @@ -194,6 +193,7 @@ test safe-6.3 {test safe interpreters knowledge of the world} { lsort $r } {byteOrder engine pathSeparator platform pointerSize wordSize} +rename SafeEval {} # More test should be added to check that hostname, nameofexecutable, aren't # leaking infos, but they still do... @@ -213,7 +213,6 @@ test safe-7.0a {example tclIndex commands, test in master interpreter} -setup { set ::auto_path $tmpAutoPath auto_reset } -match glob -result {0 ok1 0 ok2} - test safe-7.0b {example tclIndex commands, negative test in master interpreter} -setup { set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0] @@ -228,7 +227,6 @@ test safe-7.0b {example tclIndex commands, negative test in master interpreter} set ::auto_path $tmpAutoPath auto_reset } -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} - test safe-7.0c {example pkgIndex.tcl packages, test in master interpreter, child directories} -setup { set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0] @@ -238,7 +236,6 @@ test safe-7.0c {example pkgIndex.tcl packages, test in master interpreter, child set code4 [catch {package require SafeTestPackage2} msg4] set code5 [catch HeresPackage1 msg5] set code6 [catch HeresPackage2 msg6] - list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 } -cleanup { set ::auto_path $tmpAutoPath @@ -247,7 +244,6 @@ test safe-7.0c {example pkgIndex.tcl packages, test in master interpreter, child catch {rename HeresPackage1 {}} catch {rename HeresPackage2 {}} } -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} - test safe-7.0d {example pkgIndex.tcl packages, test in master interpreter, main directories} -setup { set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0 auto1] \ @@ -258,7 +254,6 @@ test safe-7.0d {example pkgIndex.tcl packages, test in master interpreter, main set code4 [catch {package require SafeTestPackage2} msg4] set code5 [catch HeresPackage1 msg5] set code6 [catch HeresPackage2 msg6] - list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 } -cleanup { set ::auto_path $tmpAutoPath @@ -267,7 +262,6 @@ test safe-7.0d {example pkgIndex.tcl packages, test in master interpreter, main catch {rename HeresPackage1 {}} catch {rename HeresPackage2 {}} } -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} - test safe-7.0e {example modules packages, test in master interpreter, replace path} -setup { set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -282,7 +276,6 @@ test safe-7.0e {example modules packages, test in master interpreter, replace pa set out0 [test0::try0] set out1 [mod1::test1::try1] set out2 [mod2::test2::try2] - list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 } -cleanup { tcl::tm::path remove [file join $TestsDir auto0 modules] @@ -295,7 +288,6 @@ test safe-7.0e {example modules packages, test in master interpreter, replace pa catch {namespace delete ::test0} catch {namespace delete ::mod1} } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} - test safe-7.0f {example modules packages, test in master interpreter, append to path} -setup { tcl::tm::path add [file join $TestsDir auto0 modules] } -body { @@ -306,7 +298,6 @@ test safe-7.0f {example modules packages, test in master interpreter, append to set out0 [test0::try0] set out1 [mod1::test1::try1] set out2 [mod2::test2::try2] - list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 } -cleanup { tcl::tm::path remove [file join $TestsDir auto0 modules] @@ -393,7 +384,8 @@ test safe-7.3 {check that safe subinterpreters work} { } set i [safe::interpCreate] set j [safe::interpCreate [list $i x]] - list $g $h [interp eval $j {join {o k} ""}] [safe::interpDelete $i] [interp exists $j] [info vars ::safe::S*] + list $g $h [interp eval $j {join {o k} ""}] [safe::interpDelete $i] \ + [interp exists $j] [info vars ::safe::S*] } {{} {} ok {} 0 {}} test safe-7.4 {tests specific path and positive search} -setup { } -body { @@ -428,24 +420,28 @@ test safe-7.4http {tests specific path and positive search, uses http1.0} -body } -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.0 -- {TCLLIB *TCLLIB/http1.0} -- {}} # test source control on file name -set i "a" test safe-8.1 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} } -body { safe::interpCreate $i $i eval {source} } -returnCodes error -cleanup { safe::interpDelete $i + unset i } -result {wrong # args: should be "source ?-encoding E? fileName"} test safe-8.2 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} } -body { safe::interpCreate $i $i eval {source a b c d e} } -returnCodes error -cleanup { safe::interpDelete $i + unset i } -result {wrong # args: should be "source ?-encoding E? fileName"} test safe-8.3 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {lappend ::log $str} @@ -456,10 +452,12 @@ test safe-8.3 {safe source control on file} -setup { list [catch {$i eval {source .}} msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i + rename safe-test-log {} + unset i log } -result {1 {permission denied} {{ERROR for slave a : ".": is a directory}}} test safe-8.4 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} @@ -470,10 +468,12 @@ test safe-8.4 {safe source control on file} -setup { list [catch {$i eval {source /abc/def}} msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i + rename safe-test-log {} + unset i log } -result {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}}} test safe-8.5 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} @@ -488,10 +488,12 @@ test safe-8.5 {safe source control on file} -setup { } msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i + rename safe-test-log {} + unset i log } -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"]] test safe-8.6 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} @@ -504,10 +506,12 @@ test safe-8.6 {safe source control on file} -setup { } msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i + rename safe-test-log {} + unset i log } -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"]] test safe-8.7 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} @@ -522,14 +526,16 @@ test safe-8.7 {safe source control on file} -setup { } msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i + rename safe-test-log {} + unset i log } -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]] test safe-8.8 {safe source forbids -rsrc} emptyTest { # Disabled this test. It was only useful for long unsupported # Mac OS 9 systems. [Bug 860a9f1945] } {} test safe-8.9 {safe source and return} -setup { + set i "a" set returnScript [makeFile {return "ok"} return.tcl] catch {safe::interpDelete $i} } -body { @@ -539,8 +545,10 @@ test safe-8.9 {safe source and return} -setup { } -cleanup { catch {safe::interpDelete $i} removeFile $returnScript + unset i } -result ok test safe-8.10 {safe source and return} -setup { + set i "a" set returnScript [makeFile {return -level 2 "ok"} return.tcl] catch {safe::interpDelete $i} } -body { @@ -553,10 +561,11 @@ test safe-8.10 {safe source and return} -setup { } -cleanup { catch {safe::interpDelete $i} removeFile $returnScript + unset i } -result ok -set i "a" test safe-9.1 {safe interps' deleteHook} -setup { + set i "a" catch {safe::interpDelete $i} set res {} } -body { @@ -569,8 +578,12 @@ test safe-9.1 {safe interps' deleteHook} -setup { } safe::interpCreate $i -deleteHook "testDelHook arg1 arg2" list [interp eval $i exit] $res +} -cleanup { + catch {rename testDelHook {}} + unset i res } -result {{} {arg1 arg2 a}} test safe-9.2 {safe interps' error in deleteHook} -setup { + set i "a" catch {safe::interpDelete $i} set res {} set log {} @@ -591,7 +604,9 @@ test safe-9.2 {safe interps' error in deleteHook} -setup { list [safe::interpDelete $i] $res $log } -cleanup { safe::setLogCmd $prevlog - unset log + catch {rename testDelHook {}} + rename safe-test-log {} + unset i log res } -result {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}}} test safe-9.3 {dual specification of statics} -returnCodes error -body { safe::interpCreate -stat true -nostat @@ -620,16 +635,18 @@ test safe-9.6 {interpConfigure widget like behaviour} -body { safe::interpConfigure $i]\ [safe::interpConfigure $i -deleteHook toto -nosta -nested 0 safe::interpConfigure $i] -} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} - +} -cleanup { + safe::interpDelete $i +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\ + {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ + {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ + {-accessPath * -statics 0 -nested 0 -deleteHook toto}} test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { # this test shall work, believed equivalent to 9.6 set i [safe::interpCreate \ -noStatics \ -nestedLoadOk \ - -deleteHook {foo bar} \ - ] - + -deleteHook {foo bar}] safe::interpConfigure $i -accessPath /foo/bar set a [safe::interpConfigure $i] set b [safe::interpConfigure $i -aCCess] @@ -644,8 +661,11 @@ test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { list $a $b $c $d $e $f $g } -cleanup { safe::interpDelete $i -} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} - + unset -nocomplain a b c d e f g i +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\ + {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ + {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ + {-accessPath * -statics 0 -nested 0 -deleteHook toto}} test safe-9.8 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset)} -setup { } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -669,7 +689,6 @@ test safe-9.8 {interpConfigure change the access path; tclIndex commands unaffec safe::interpConfigure $i -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto2] \ [file join $TestsDir auto0 auto1]] - # Inspect. set confB [safe::interpConfigure $i] set mappB [mapList $PathMapp [dict get $confB -accessPath]] @@ -686,7 +705,6 @@ test safe-9.8 {interpConfigure change the access path; tclIndex commands unaffec } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} - test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset)} -setup { } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -708,7 +726,6 @@ test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffec safe::interpConfigure $i -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto2] \ [file join $TestsDir auto0 auto1]] - # Inspect. set confB [safe::interpConfigure $i] set mappB [mapList $PathMapp [dict get $confB -accessPath]] @@ -726,7 +743,6 @@ test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffec 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} - test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement} -setup { } -body { # For complete correspondence to safe-9.10opt, include auto0 in access path. @@ -734,7 +750,6 @@ test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages un [file join $TestsDir auto0] \ [file join $TestsDir auto0 auto1] \ [file join $TestsDir auto0 auto2]]] - # Inspect. set confA [safe::interpConfigure $i] set mappA [mapList $PathMapp [dict get $confA -accessPath]] @@ -752,7 +767,6 @@ test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages un [file join $TestsDir auto0] \ [file join $TestsDir auto0 auto2] \ [file join $TestsDir auto0 auto1]] - # Inspect. set confB [safe::interpConfigure $i] set mappB [mapList $PathMapp [dict get $confB -accessPath]] @@ -773,13 +787,11 @@ test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages un {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ 0 OK1 0 OK2} - test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0} -setup { } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ [file join $TestsDir auto0 auto2]]] - # Inspect. set confA [safe::interpConfigure $i] set mappA [mapList $PathMapp [dict get $confA -accessPath]] @@ -793,7 +805,6 @@ test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages un safe::interpConfigure $i -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto2] \ [file join $TestsDir auto0 auto1]] - # Inspect. set confB [safe::interpConfigure $i] set mappB [mapList $PathMapp [dict get $confB -accessPath]] @@ -806,8 +817,9 @@ test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages un set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] - list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB -- \ - $code5 $msg5 $code6 $msg6 + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- \ + $code5 $msg5 $code6 $msg6 } -cleanup { safe::interpDelete $i } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ @@ -842,7 +854,8 @@ test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages fa set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] - list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- $mappA -- $mappB + list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \ + $mappA -- $mappB } -cleanup { safe::interpDelete $i } -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ @@ -916,7 +929,6 @@ test safe-9.21 {interpConfigure change the access path; check module loading; st safe::interpConfigure $i -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ [file join $TestsDir auto0 auto2]] - # Inspect. set confB [safe::interpConfigure $i] set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] @@ -938,9 +950,10 @@ test safe-9.21 {interpConfigure change the access path; check module loading; st set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ - $out0 $out1 $out2 + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 } -cleanup { tcl::tm::path remove [file join $TestsDir auto0 modules] foreach path [lreverse $oldTm] { @@ -978,7 +991,6 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st safe::interpConfigure $i -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ [file join $TestsDir auto0 auto2]] - # Inspect. set confB [safe::interpConfigure $i] set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] @@ -995,9 +1007,10 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ - $out0 $out1 $out2 + list [lsort [list $path0 $path1 $path2]] -- $modsA --\ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 } -cleanup { tcl::tm::path remove [file join $TestsDir auto0 modules] foreach path [lreverse $oldTm] { @@ -1040,7 +1053,6 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st safe::interpConfigure $i -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ [file join $TestsDir auto0 auto2]] - # Inspect. set confB [safe::interpConfigure $i] set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] @@ -1062,10 +1074,10 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ - $out0 $out1 $out2 - + list [lsort [list $path0 $path1 $path2]] -- $modsA --\ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 } -cleanup { tcl::tm::path remove [file join $TestsDir auto0 modules] foreach path [lreverse $oldTm] { @@ -1108,7 +1120,6 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st safe::interpConfigure $i -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ [file join $TestsDir auto0 auto2]] - # Inspect. set confB [safe::interpConfigure $i] set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] @@ -1125,9 +1136,10 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ - $out0 $out1 $out2 + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 } -cleanup { tcl::tm::path remove [file join $TestsDir auto0 modules] foreach path [lreverse $oldTm] { @@ -1593,8 +1605,8 @@ test safe-16.4 {Bug 3529949: defang ~user in globs} -setup { safe::interpDelete $i } -result {} -set ::auto_path $saveAutoPath -unset saveAutoPath TestsDir PathMapp +set ::auto_path $SaveAutoPath +unset SaveAutoPath TestsDir PathMapp rename mapList {} rename mapAndSortList {} -- cgit v0.12 From 2a52ff28dd5deb1dc6fde4f0fdbbb85aa6b4efe3 Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 18 Jul 2020 12:53:53 +0000 Subject: Remove code block in ::safe::AliasGlob that no longer serves a useful purpose. --- library/safe.tcl | 7 ------- 1 file changed, 7 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index 74aee87..e645085 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -792,13 +792,6 @@ proc ::safe::AliasGlob {slave args} { set virtualdir [lindex $args [incr at]] incr at } - pkgIndex.tcl { - # Oops, this is globbing a subdirectory in regular package - # search. That is not wanted. Abort, handler does catch - # already (because glob was not defined before). See - # package.tcl, lines 484ff in tclPkgUnknown. - return -code error "unknown command glob" - } -* { Log $slave "Safe base rejecting glob option '$opt'" return -code error "Safe base rejecting glob option '$opt'" -- cgit v0.12 From a300508fee9c27bc2ea2bf95a19d7007dcd26424 Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 18 Jul 2020 13:09:25 +0000 Subject: Remove unused code for *.tm from ::safe::AliasGlob. --- library/safe.tcl | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index e645085..843255a 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -831,8 +831,7 @@ proc ::safe::AliasGlob {slave args} { } elseif {[string match ~* $thedir]} { set thedir ./$thedir } - if {$thedir eq "*" && - ($thefile eq "pkgIndex.tcl" || $thefile eq "*.tm")} { + if {($thedir eq "*") && ($thefile eq "pkgIndex.tcl")} { set mapped 0 foreach d [glob -directory [TranslatePath $slave $virtualdir] \ -types d -tails *] { -- cgit v0.12 From 690f2c283978a046e78664a1070c5c0bf5ddf67f Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 18 Jul 2020 13:18:48 +0000 Subject: Bugfix argument combination -- and -directory in ::safe::AliasGlob. --- library/safe.tcl | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/library/safe.tcl b/library/safe.tcl index 843255a..410a5c1 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -815,7 +815,11 @@ proc ::safe::AliasGlob {slave args} { if {$got(-nocomplain)} return return -code error "permission denied" } - lappend cmd -directory $dir + if {$got(--)} { + set cmd [linsert $cmd end-1 -directory $dir] + } else { + lappend cmd -directory $dir + } } # Apply the -join semantics ourselves -- cgit v0.12 From 6310c709d39e30dcefc165aa242973e919d86134 Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 18 Jul 2020 13:22:31 +0000 Subject: Update comments about safe interpreters in library/tm.tcl and library/package.tcl so they agree with code --- library/package.tcl | 10 +++++++--- library/tm.tcl | 11 ++++++----- 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/library/package.tcl b/library/package.tcl index 44e3b28..d6280ae 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -479,9 +479,12 @@ proc tclPkgUnknown {name args} { } set tclSeenPath($dir) 1 - # we can't use glob in safe interps, so enclose the following in a - # catch statement, where we get the pkgIndex files out of the - # subdirectories + # Get the pkgIndex.tcl files in subdirectories of auto_path directories. + # - Safe Base interpreters have a restricted "glob" command that + # works in this case. + # - The "catch" was essential when there was no safe glob and every + # call in a safe interp failed; it is retained only for corner + # cases in which the eventual call to glob returns an error. catch { foreach file [glob -directory $dir -join -nocomplain \ * pkgIndex.tcl] { @@ -585,6 +588,7 @@ proc tcl::MacOSXPkgUnknown {original name args} { set tclSeenPath($dir) 1 # get the pkgIndex files out of the subdirectories + # Safe interpreters do not use tcl::MacOSXPkgUnknown - see init.tcl. foreach file [glob -directory $dir -join -nocomplain \ * Resources Scripts pkgIndex.tcl] { set dir [file dirname $file] diff --git a/library/tm.tcl b/library/tm.tcl index 0ed3f1a..c60084c 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -212,11 +212,12 @@ proc ::tcl::tm::UnknownHandler {original name args} { } set strip [llength [file split $path]] - # We can't use glob in safe interps, so enclose the following in a - # catch statement, where we get the module files out of the - # subdirectories. In other words, Tcl Modules are not-functional - # in such an interpreter. This is the same as for the command - # "tclPkgUnknown", i.e. the search for regular packages. + # Get the module files out of the subdirectories. + # - Safe Base interpreters have a restricted "glob" command that + # works in this case. + # - The "catch" was essential when there was no safe glob and every + # call in a safe interp failed; it is retained only for corner + # cases in which the eventual call to glob returns an error. catch { # We always look for _all_ possible modules in the current -- cgit v0.12 From 201d01f9da1f2fb006cc4c0fc265e552cf9c2703 Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 18 Jul 2020 17:51:27 +0000 Subject: Add explanatory comments to safe::AliasGlob --- library/safe.tcl | 33 +++++++++++++++++++++++++++++++-- tests/safe.test | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 80 insertions(+), 2 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index 410a5c1..da6523c 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -822,19 +822,27 @@ proc ::safe::AliasGlob {slave args} { } } - # Apply the -join semantics ourselves + # Apply the -join semantics ourselves. if {$got(-join)} { set args [lreplace $args $at end [join [lrange $args $at end] "/"]] } - # Process remaining pattern arguments + # Process the pattern arguments. If we've done a join there is only one + # pattern argument. + set firstPattern [llength $cmd] foreach opt [lrange $args $at end] { if {![regexp $dirPartRE $opt -> thedir thefile]} { set thedir . + # The *.tm search comes here. } elseif {[string match ~* $thedir]} { set thedir ./$thedir } + # "Special" treatment for (joined) argument {*/pkgIndex.tcl}. + # Do the expansion of "*" here, and filter out any directories that are + # not in the access path. The outcome is to lappend to cmd a path of + # the form $virtualdir/subdir/pkgIndex.tcl for each subdirectory subdir, + # after removing any subdir that are not in the access path. if {($thedir eq "*") && ($thefile eq "pkgIndex.tcl")} { set mapped 0 foreach d [glob -directory [TranslatePath $slave $virtualdir] \ @@ -847,7 +855,19 @@ proc ::safe::AliasGlob {slave args} { } } if {$mapped} continue + # Don't [continue] if */pkgIndex.tcl has no matches in the access + # path. The pattern will now receive the same treatment as a + # "non-special" pattern (and will fail because it includes a "*" in + # the directory name). } + # Any directory pattern that is not an exact (i.e. non-glob) match to a + # directory in the access path will be rejected here. + # - Rejections include any directory pattern that has glob matching + # patterns "*", "?", backslashes, braces or square brackets, (UNLESS + # it corresponds to a genuine directory name AND that directory is in + # the access path). + # - The only "special matching characters" that remain in patterns for + # processing by glob are in the filename tail. try { DirInAccessPath $slave [TranslatePath $slave \ [file join $virtualdir $thedir]] @@ -865,8 +885,17 @@ proc ::safe::AliasGlob {slave args} { return } try { + # >>>>>>>>>> HERE'S THE CALL TO SAFE INTERP GLOB <<<<<<<<<< + # - Pattern arguments added to cmd have NOT been translated from tokens. + # Only the virtualdir is translated (to dir). + # - In the pkgIndex.tcl case, there is no "*" in the pattern arguments, + # which are a list of names each with tail pkgIndex.tcl. The purpose + # of the call to glob is to remove the names for which the file does + # not exist. set entries [::interp invokehidden $slave glob {*}$cmd] } on error msg { + # This is the only place that a call with -nocomplain and no invalid + # "dash-options" can return an error. Log $slave $msg return -code error "script error" } diff --git a/tests/safe.test b/tests/safe.test index 2683b9c..9e90236 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1572,6 +1572,7 @@ test safe-16.1 {Bug 3529949: defang ~ in paths} -setup { } -cleanup { safe::interpDelete $i set env(HOME) $savedHOME + unset savedHOME } -result {./~} test safe-16.2 {Bug 3529949: defang ~user in paths} -setup { set i [safe::interpCreate] @@ -1581,6 +1582,7 @@ test safe-16.2 {Bug 3529949: defang ~user in paths} -setup { "file join \[file dirname ~$user\] \[file tail ~$user\]"] } -cleanup { safe::interpDelete $i + unset user } -result {./~USER} test safe-16.3 {Bug 3529949: defang ~ in globs} -setup { set syntheticHOME [makeDirectory foo] @@ -1595,6 +1597,7 @@ test safe-16.3 {Bug 3529949: defang ~ in globs} -setup { safe::interpDelete $i set env(HOME) $savedHOME removeDirectory $syntheticHOME + unset savedHOME syntheticHOME } -result {} test safe-16.4 {Bug 3529949: defang ~user in globs} -setup { set i [safe::interpCreate] @@ -1604,6 +1607,52 @@ test safe-16.4 {Bug 3529949: defang ~user in globs} -setup { } -cleanup { safe::interpDelete $i } -result {} +test safe-16.5 {Bug 3529949: defang ~ in paths used by AliasGlob (1)} -setup { + set savedHOME $env(HOME) + set env(HOME) /foo/bar + set i [safe::interpCreate] +} -body { + $i eval { + set d [format %c 126] + file join {$p(:0:)} $d + } +} -cleanup { + safe::interpDelete $i + set env(HOME) $savedHOME + unset savedHOME +} -result {~} +test safe-16.6 {Bug 3529949: defang ~ in paths used by AliasGlob (2)} -setup { + set savedHOME $env(HOME) + set env(HOME) /foo/bar + set i [safe::interpCreate] +} -body { + $i eval { + set d [format %c 126] + file join {$p(:0:)/foo/bar} $d + } +} -cleanup { + safe::interpDelete $i + set env(HOME) $savedHOME + unset savedHOME +} -result {~} +test safe-16.7 {Bug 3529949: defang ~user in paths used by AliasGlob (1)} -setup { + set i [safe::interpCreate] + set user $tcl_platform(user) +} -body { + string map [list $user USER] [$i eval [list file join {$p(:0:)} ~$user]] +} -cleanup { + safe::interpDelete $i + unset user +} -result {~USER} +test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup { + set i [safe::interpCreate] + set user $tcl_platform(user) +} -body { + string map [list $user USER] [$i eval [list file join {$p(:0:)/foo/bar} ~$user]] +} -cleanup { + safe::interpDelete $i + unset user +} -result {~USER} set ::auto_path $SaveAutoPath unset SaveAutoPath TestsDir PathMapp -- cgit v0.12 From d12eb85c8fe92ca27b4f03950a447068c2418cb8 Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 18 Jul 2020 18:06:30 +0000 Subject: Simplify case analysis in safe::AliasGlob --- library/safe.tcl | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/library/safe.tcl b/library/safe.tcl index da6523c..f0a14a3 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -820,6 +820,13 @@ proc ::safe::AliasGlob {slave args} { } else { lappend cmd -directory $dir } + } else { + # The code after this "if ... else" block would conspire to return with + # no results in this case, if it were allowed to proceed. Instead, + # return now and reduce the number of cases to be considered later. + Log $slave {option -directory must be supplied} + if {$got(-nocomplain)} return + return -code error "permission denied" } # Apply the -join semantics ourselves. -- cgit v0.12 From a541a7be4cbbd4b2e5cca7ff65b98010dc224929 Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 18 Jul 2020 18:51:53 +0000 Subject: Remove an old fix for ~ expansion in safe::AliasGlob that is now fixed by other means --- library/safe.tcl | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index f0a14a3..4540be3 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -842,8 +842,6 @@ proc ::safe::AliasGlob {slave args} { if {![regexp $dirPartRE $opt -> thedir thefile]} { set thedir . # The *.tm search comes here. - } elseif {[string match ~* $thedir]} { - set thedir ./$thedir } # "Special" treatment for (joined) argument {*/pkgIndex.tcl}. # Do the expansion of "*" here, and filter out any directories that are @@ -875,6 +873,12 @@ proc ::safe::AliasGlob {slave args} { # the access path). # - The only "special matching characters" that remain in patterns for # processing by glob are in the filename tail. + # - [file join $anything ~${foo}] is ~${foo}, which is not an exact + # match to any directory in the access path. Hence directory patterns + # that begin with "~" are rejected here. Tests safe-16.[5-8] check + # that "file join" remains as required and does not expand ~${foo}. + # - Bug [3529949] relates to unwanted expansion of ~${foo} and this is + # how the present code avoids the bug. All tests safe-16.* relate. try { DirInAccessPath $slave [TranslatePath $slave \ [file join $virtualdir $thedir]] -- cgit v0.12