summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorkjnash <k.j.nash@usa.net>2020-07-19 00:19:26 (GMT)
committerkjnash <k.j.nash@usa.net>2020-07-19 00:19:26 (GMT)
commit969bd53c8ad63172ae670ba92eed2ab62cbf5e63 (patch)
tree9bcadff8a9b2229bc11dffcfdf827a197f72dd96
parent3398002e97de09f498bbcdf3ec827666b514f79a (diff)
parentd91e1e6efbf64ebd8e820892a06b88882a49b0ed (diff)
downloadtcl-969bd53c8ad63172ae670ba92eed2ab62cbf5e63.zip
tcl-969bd53c8ad63172ae670ba92eed2ab62cbf5e63.tar.gz
tcl-969bd53c8ad63172ae670ba92eed2ab62cbf5e63.tar.bz2
Merge safe-extra-tests-8-7
-rw-r--r--doc/CrtAlias.38
-rw-r--r--doc/clock.n12
-rw-r--r--generic/tclBasic.c2
-rw-r--r--generic/tclInt.decls2
-rw-r--r--generic/tclIntDecls.h8
-rw-r--r--generic/tclInterp.c18
-rw-r--r--generic/tclStubInit.c2
-rw-r--r--library/package.tcl10
-rw-r--r--library/safe.tcl74
-rw-r--r--library/tm.tcl11
-rw-r--r--macosx/tclMacOSXNotify.c127
-rw-r--r--tests/pkgIndex.tcl2
-rw-r--r--tests/safe.test171
13 files changed, 295 insertions, 152 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/doc/clock.n b/doc/clock.n
index f30ad24..a3f934a 100644
--- a/doc/clock.n
+++ b/doc/clock.n
@@ -471,36 +471,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
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..de8cd32 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);
}
}
@@ -2250,23 +2250,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((const char *)Tcl_GetHashKey(&iiPtr->master.slaveTable,
iiPtr->slave.slaveEntryPtr), -1));
return TCL_OK;
@@ -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 */
diff --git a/library/package.tcl b/library/package.tcl
index 6c87ec1..bf3e926 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] {
@@ -593,6 +596,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/safe.tcl b/library/safe.tcl
index 46f0c64..b73aad5 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -483,14 +483,6 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook au
lappend slave_tm_rel $relpath
}
}
- foreach sub [glob -nocomplain -directory $dir -type d *] {
- lappend slave_tm_roots [file normalize $sub] [dict get $slave_tm_roots $dir]
- set lenny [string length [dict get $slave_tm_roots $dir]]
- set relpath [string range [file normalize $sub] $lenny+1 end]
- if {$relpath ni $slave_tm_rel} {
- lappend slave_tm_rel $relpath
- }
- }
}
set firstpass 0
}
@@ -897,17 +889,6 @@ proc ::safe::AliasGlob {slave args} {
set virtualdir [lindex $args [incr at]]
incr at
}
- pkgIndex.tcl {
- if {$AutoPathSync} {
- # 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"
- } else {
- break
- }
- }
-* {
Log $slave "Safe base rejecting glob option '$opt'"
return -code error "Safe base rejecting glob option '$opt'"
@@ -932,7 +913,18 @@ 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
+ }
+ } 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 (hence -join not copied to $cmd)
@@ -940,16 +932,21 @@ proc ::safe::AliasGlob {slave args} {
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 .
- } elseif {[string match ~* $thedir]} {
- set thedir ./$thedir
+ # The *.tm search comes here.
}
- if {$thedir eq "*" &&
- ($thefile eq "pkgIndex.tcl" || $thefile eq "*.tm")} {
+ # "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] \
-types d -tails *] {
@@ -961,7 +958,25 @@ 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.
+ # - [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]]
@@ -979,8 +994,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/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
diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c
index 8f1dbba..ee271e1 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 <os/lock.h>
+#undef TCL_MAC_DEBUG_NOTIFIER
+#endif
+
#ifdef HAVE_COREFOUNDATION /* Traditional unix select-based notifier is
* in tclUnixNotfy.c */
#include <CoreFoundation/CoreFoundation.h>
@@ -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
@@ -172,26 +186,45 @@ SpinLockTry(
#pragma GCC diagnostic pop
#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(&notifierInitLock)
+#define UNLOCK_NOTIFIER_INIT os_unfair_lock_unlock(&notifierInitLock)
+#define LOCK_NOTIFIER os_unfair_lock_lock(&notifierLock)
+#define UNLOCK_NOTIFIER os_unfair_lock_unlock(&notifierLock)
+#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(&notifierInitLock)
#define UNLOCK_NOTIFIER_INIT SpinLockUnlock(&notifierInitLock)
#define LOCK_NOTIFIER SpinLockLock(&notifierLock)
#define UNLOCK_NOTIFIER SpinLockUnlock(&notifierLock)
#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: " \
@@ -218,7 +251,7 @@ static OSSpinLock notifierLock = SPINLOCK_INIT;
#undef LOCK_NOTIFIER
#define LOCK_NOTIFIER SpinLockLockDbg(&notifierLock)
#undef LOCK_NOTIFIER_TSD
-#define LOCK_NOTIFIER_TSD SpinLockLockDbg(&tsdPtr->tsdLock)
+#define LOCK_NOTIFIER_TSD SpinLockLockDbg(tsdPtr->tsdLock)
#include <asl.h>
static FILE *notifierLog = NULL;
#ifndef NOTIFIER_LOG
@@ -325,8 +358,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 */
@@ -339,9 +370,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
@@ -526,7 +562,6 @@ Tcl_InitNotifier(void)
/*
* Initialize support for weakly imported spinlock API.
*/
-
if (pthread_once(&spinLockLockInitControl, SpinLockLockInit)) {
Tcl_Panic("Tcl_InitNotifier: pthread_once failed");
}
@@ -563,7 +598,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) {
@@ -581,7 +616,7 @@ Tcl_InitNotifier(void)
*/
runLoopObserverTcl = CFRunLoopObserverCreate(NULL,
- kCFRunLoopEntry|kCFRunLoopExit|kCFRunLoopBeforeWaiting, TRUE,
+ kCFRunLoopEntry|kCFRunLoopExit, TRUE,
LONG_MIN, UpdateWaitingListAndServiceEvents,
&runLoopObserverContext);
if (!runLoopObserverTcl) {
@@ -597,7 +632,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;
@@ -655,7 +694,6 @@ Tcl_InitNotifier(void)
ENABLE_ASL;
notifierCount++;
UNLOCK_NOTIFIER_INIT;
-
return tsdPtr;
}
@@ -1291,6 +1329,10 @@ Tcl_WaitForEvent(
Tcl_Panic("Tcl_WaitForEvent: Notifier not initialized");
}
+ /*
+ * A NULL timePtr means wait forever.
+ */
+
if (timePtr) {
Tcl_Time vTime = *timePtr;
@@ -1304,14 +1346,23 @@ 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.
+ * 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 = tsdPtr->runLoopRunning ? 0 : 0.0001;
}
}
@@ -1324,18 +1375,18 @@ 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,
- waitTime, TRUE);
+ runLoopStatus = CFRunLoopRunInMode(
+ runLoopRunning ? tclEventsOnlyRunLoopMode : kCFRunLoopDefaultMode,
+ waitTime, TRUE);
tsdPtr->runLoopRunning = runLoopRunning;
LOCK_NOTIFIER_TSD;
@@ -1453,7 +1504,6 @@ UpdateWaitingListAndServiceEvents(
void *info)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)info;
-
if (tsdPtr->sleeping) {
return;
}
@@ -1476,19 +1526,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;
}
@@ -1521,7 +1558,7 @@ OnOffWaitingList(
{
int changeWaitingList;
-#ifdef TCL_MAC_DEBUG_NOTIFIER
+#if defined(TCL_MAC_DEBUG_NOTIFIER) && !defined(USE_OS_UNFAIR_LOCK)
if (SpinLockTry(&notifierLock)) {
Tcl_Panic("OnOffWaitingList: notifierLock unlocked");
}
@@ -2052,9 +2089,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) {
diff --git a/tests/pkgIndex.tcl b/tests/pkgIndex.tcl
index 96542f9..9d89277 100644
--- a/tests/pkgIndex.tcl
+++ b/tests/pkgIndex.tcl
@@ -1,3 +1,3 @@
#! /usr/bin/env tclsh
-package ifneeded tcltests 0.1 [list source $dir/tcltests.tcl] \ No newline at end of file
+package ifneeded tcltests 0.1 [list source $dir/tcltests.tcl]
diff --git a/tests/safe.test b/tests/safe.test
index 38b1705..981165a 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -23,7 +23,7 @@ foreach i [interp slaves] {
interp delete $i
}
-set saveAutoPath $::auto_path
+set SaveAutoPath $::auto_path
set ::auto_path [info library]
# The defunct package http 1.0 was convenient for testing package loading.
@@ -254,6 +254,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...
@@ -324,7 +325,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
@@ -360,7 +360,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
@@ -401,7 +400,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]
@@ -450,7 +448,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]
@@ -654,8 +651,8 @@ test safe-7.2opt {tests specific path and interpFind/AddToAccessPath with conven
if {$SyncExists} {
safe::setAutoPathSync $SyncVal_TMP
}
-} -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 {}} {
@@ -667,7 +664,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 with conventional AutoPathSync} -setup {
# All ::safe commands are loaded at start of file.
@@ -790,24 +788,28 @@ test safe-7.5 {tests positive and negative module loading with conventional Auto
} -result {1 {can't find package shell} 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}
@@ -818,10 +820,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}
@@ -832,10 +836,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}
@@ -850,10 +856,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}
@@ -866,10 +874,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}
@@ -884,14 +894,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 {
@@ -901,8 +913,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 {
@@ -915,10 +929,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 {
@@ -931,8 +946,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 {}
@@ -953,7 +972,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
@@ -984,15 +1005,16 @@ test safe-9.6 {interpConfigure widget like behaviour} -body {
safe::interpConfigure $i]
} -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}}
+} -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]
@@ -1007,7 +1029,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 {
set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}]
if {$SyncExists} {
@@ -1036,7 +1062,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]]
@@ -1056,7 +1081,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.8z {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset); zipfs} -setup {
set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}]
if {$SyncExists} {
@@ -1104,7 +1128,6 @@ test safe-9.8z {interpConfigure change the access path; tclIndex commands unaffe
} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\
{TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\
{TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*}}
-
test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset)} -setup {
set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}]
if {$SyncExists} {
@@ -1131,7 +1154,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]]
@@ -1152,7 +1174,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.9z {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset); zipfs} -setup {
set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}]
if {$SyncExists} {
@@ -1211,7 +1232,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]]
@@ -1362,7 +1382,6 @@ test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages un
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]]
@@ -1376,7 +1395,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]]
@@ -1389,8 +1407,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
if {$SyncExists} {
@@ -1480,7 +1499,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
if {$SyncExists} {
@@ -1700,7 +1720,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]]
@@ -1722,9 +1741,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] {
@@ -1840,7 +1860,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]]
@@ -1857,9 +1876,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] {
@@ -1975,7 +1995,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]]
@@ -1997,10 +2016,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] {
@@ -2126,7 +2145,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]]
@@ -2143,9 +2161,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] {
@@ -2647,6 +2666,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]
@@ -2656,6 +2676,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]
@@ -2670,6 +2691,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]
@@ -2679,6 +2701,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}
### 17. The first element in a slave's ::auto_path and access path must be [info library].
@@ -3153,10 +3221,9 @@ test safe-19.2 {Check that each directory of the module path is a valid token} -
safe::interpDelete $i
} -result {}
-
-set ::auto_path $saveAutoPath
+set ::auto_path $SaveAutoPath
zipfs unmount ${ZipMountPoint}
-unset pkgOptErrMsg pkgOptDir pkgJarDir saveAutoPath TestsDir ZipMountPoint PathMapp
+unset pkgOptErrMsg pkgOptDir pkgJarDir SaveAutoPath TestsDir ZipMountPoint PathMapp
rename mapList {}
rename mapAndSortList {}
# cleanup