diff options
| author | jan.nijtmans <nijtmans@users.sourceforge.net> | 2020-10-24 14:50:11 (GMT) |
|---|---|---|
| committer | jan.nijtmans <nijtmans@users.sourceforge.net> | 2020-10-24 14:50:11 (GMT) |
| commit | 63855497af431a6ee84d67b62ade8694485d76c9 (patch) | |
| tree | 8239e1a67cec1bb976b23a1d96024097fc93b8a1 | |
| parent | fe94c1d6c4fa1c0d810d2eb6b845e7d0faf8812c (diff) | |
| parent | 48d0827130389368a247f26b480bd819a1c753e5 (diff) | |
| download | tcl-63855497af431a6ee84d67b62ade8694485d76c9.zip tcl-63855497af431a6ee84d67b62ade8694485d76c9.tar.gz tcl-63855497af431a6ee84d67b62ade8694485d76c9.tar.bz2 | |
Merge 8.7
333 files changed, 6322 insertions, 3461 deletions
diff --git a/.fossil-settings/binary-glob b/.fossil-settings/binary-glob index a6eec26..7e8f357 100644 --- a/.fossil-settings/binary-glob +++ b/.fossil-settings/binary-glob @@ -1,20 +1,3 @@ -compat/zlib/win32/zdll.lib -compat/zlib/win32/zlib1.dll -compat/zlib/win64/zdll.lib -compat/zlib/win64/zlib1.dll -compat/zlib/win64/libz.dll.a -compat/zlib/zlib.3.pdf -compat/zlib/win32/zdll.lib -compat/zlib/win32/zlib1.dll -compat/zlib/win64/zdll.lib -compat/zlib/win64/zlib1.dll -compat/zlib/win64/libz.dll.a -compat/zlib/zlib.3.pdf -libtommath/win32/tommath.lib -libtommath/win32/libtommath.dll -libtommath/win64/tommath.lib -libtommath/win64/libtommath.dll -libtommath/win64/libtommath.dll.a *.a *.bmp *.dll diff --git a/.fossil-settings/ignore-glob b/.fossil-settings/ignore-glob index a58aef5..651d616 100644 --- a/.fossil-settings/ignore-glob +++ b/.fossil-settings/ignore-glob @@ -32,7 +32,7 @@ libtommath/pretty.build libtommath/tommath.src libtommath/*.log libtommath/*.pdf -libtommath/gen.pl +libtommath/*.pl libtommath/*.sh libtommath/doc/* libtommath/tombc/* @@ -64,4 +64,5 @@ win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj +win/nmakehlp.out win/nmhlp-out.txt diff --git a/.gitattributes b/.gitattributes index e9a67c8..8a49592 100644 --- a/.gitattributes +++ b/.gitattributes @@ -27,6 +27,7 @@ # Denote all files that are truly binary and should not be modified. *.a binary +*.bmp binary *.dll binary *.exe binary *.gif binary diff --git a/.travis.yml b/.travis.yml index 67f1783..ba88156 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,8 @@ language: c addons: apt: + sources: + - ubuntu-toolchain-r-test packages: - binutils-mingw-w64-i686 - binutils-mingw-w64-x86-64 @@ -11,44 +13,44 @@ addons: - gcc-multilib jobs: include: -# Testing on Linux with various compilers +# Testing on Linux GCC - name: "Linux/GCC/Shared" os: linux - dist: bionic + dist: focal compiler: gcc env: - BUILD_DIR=unix - name: "Linux/GCC/Shared: UTF_MAX=4" os: linux - dist: bionic + dist: focal compiler: gcc env: - BUILD_DIR=unix - CFGOPT=CFLAGS=-DTCL_UTF_MAX=4 - name: "Linux/GCC/Shared: NO_DEPRECATED" os: linux - dist: bionic + dist: focal compiler: gcc env: - BUILD_DIR=unix - CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1" - name: "Linux/GCC/Static" os: linux - dist: bionic + dist: focal compiler: gcc env: - CFGOPT="--disable-shared" - BUILD_DIR=unix - name: "Linux/GCC/Debug" os: linux - dist: bionic + dist: focal compiler: gcc env: - BUILD_DIR=unix - CFGOPT="--enable-symbols" - name: "Linux/GCC/Mem-Debug" os: linux - dist: bionic + dist: focal compiler: gcc env: - BUILD_DIR=unix @@ -56,34 +58,20 @@ jobs: # C++ build. - name: "Linux/G++/Shared" os: linux - dist: bionic + dist: focal compiler: g++ env: - BUILD_DIR=unix - CFGOPT="CC=g++ CFLAGS=-Dregister=dont+use+register" -# Older versions of GCC... - - name: "Linux/GCC 7/Shared" +# Newer/Older versions of GCC + - name: "Linux/GCC 10/Shared" os: linux - dist: bionic - compiler: gcc-7 + dist: focal + compiler: gcc-10 addons: apt: - sources: - - ubuntu-toolchain-r-test packages: - - g++-7 - env: - - BUILD_DIR=unix - - name: "Linux/GCC 6/Shared" - os: linux - dist: bionic - compiler: gcc-6 - addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - g++-6 + - g++-10 env: - BUILD_DIR=unix - name: "Linux/GCC 5/Shared" @@ -92,16 +80,14 @@ jobs: compiler: gcc-5 addons: apt: - sources: - - ubuntu-toolchain-r-test packages: - g++-5 env: - BUILD_DIR=unix -# Clang +# Testing on Linux Clang - name: "Linux/Clang/Shared" os: linux - dist: bionic + dist: focal compiler: clang env: - BUILD_DIR=unix @@ -114,29 +100,29 @@ jobs: - CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1" - name: "Linux/Clang/Static" os: linux - dist: bionic + dist: focal compiler: clang env: - CFGOPT="--disable-shared" - BUILD_DIR=unix - name: "Linux/Clang/Debug" os: linux - dist: bionic + dist: focal compiler: clang env: - BUILD_DIR=unix - CFGOPT="--enable-symbols" - name: "Linux/Clang/Mem-Debug" os: linux - dist: bionic + dist: focal compiler: clang env: - BUILD_DIR=unix - CFGOPT="--enable-symbols=mem" # Testing on Mac, various styles - - name: "macOS/Clang/Xcode 11.5/Shared" + - name: "macOS/Clang/Xcode 12/Shared" os: osx - osx_image: xcode11.5 + osx_image: xcode12.2 env: - BUILD_DIR=macosx install: [] @@ -144,14 +130,15 @@ jobs: - make all # The styles=develop avoids some weird problems on OSX - make test styles=develop - - name: "macOS/Clang/Xcode 11.5/Shared/Unix-like" + - name: "macOS/Clang/Xcode 12/Shared/Unix-like" os: osx - osx_image: xcode11.5 + osx_image: xcode12.2 env: - BUILD_DIR=unix - - name: "macOS/Clang/Xcode 11.5/Shared/libtommath" + - CFGOPT="--enable-dtrace" + - name: "macOS/Clang/Xcode 12/Shared/libtommath" os: osx - osx_image: xcode11.5 + osx_image: xcode12.2 env: - BUILD_DIR=macosx install: [] @@ -160,18 +147,26 @@ jobs: homebrew: packages: - libtommath - - name: "macOS/Clang++/Xcode 11.5/Shared" + - name: "macOS/Clang++/Xcode 12/Shared" os: osx - osx_image: xcode11.5 + osx_image: xcode12.2 env: - BUILD_DIR=unix - - CFGOPT="CC=clang++ --enable-framework CFLAGS=-Dregister=dont+use+register CPPFLAGS=-D__private_extern__=extern" + - CFGOPT="CC=clang++ --enable-framework --enable-dtrace CFLAGS=-Dregister=dont+use+register CPPFLAGS=-D__private_extern__=extern" script: - make all tcltest +# Newer MacOS versions + - name: "macOS/Clang/Xcode 12/Universal Apps/Shared" + os: osx + osx_image: xcode12u + env: + - BUILD_DIR=macosx + install: [] + script: *mactest # Older MacOS versions - name: "macOS/Clang/Xcode 11/Shared" os: osx - osx_image: xcode11 + osx_image: xcode11.7 env: - BUILD_DIR=macosx install: [] @@ -185,7 +180,7 @@ jobs: script: *mactest - name: "macOS/Clang/Xcode 9/Shared" os: osx - osx_image: xcode9.2 + osx_image: xcode9.4 env: - BUILD_DIR=macosx install: [] @@ -201,7 +196,7 @@ jobs: # Doesn't run tests because wine is only an imperfect Windows emulation - name: "Linux-cross-Windows/GCC/Shared/no test" os: linux - dist: bionic + dist: focal compiler: x86_64-w64-mingw32-gcc env: - BUILD_DIR=win @@ -215,7 +210,7 @@ jobs: # Doesn't run tests because wine is only an imperfect Windows emulation - name: "Linux-cross-Windows-32/GCC/Shared/no test" os: linux - dist: bionic + dist: focal compiler: i686-w64-mingw32-gcc env: - BUILD_DIR=win @@ -229,6 +224,8 @@ jobs: - BUILD_DIR=win - VCDIR="/C/Program Files (x86)/Microsoft Visual Studio/2017/BuildTools/VC/Auxiliary/Build" before_install: &vcpreinst + - rm -rf tests/safe-stock8*.test + - touch generic/tclStubInit.c generic/tclOOStubInit.c generic/tclOOScript.h - PATH="$PATH:$VCDIR" - cd ${BUILD_DIR} install: [] @@ -343,6 +340,8 @@ jobs: - BUILD_DIR=win - CFGOPT="--enable-64bit" before_install: &makepreinst + - rm -rf tests/safe-stock8*.test + - touch generic/tclStubInit.c generic/tclOOStubInit.c generic/tclOOScript.h - choco install -y make zip - cd ${BUILD_DIR} - name: "Windows/GCC/Shared: UTF_MAX=4" @@ -443,13 +442,15 @@ jobs: # "make dist" only - name: "Linux: make dist" os: linux - dist: bionic + dist: focal compiler: gcc env: - BUILD_DIR=unix script: - make dist before_install: + - rm -rf tests/safe-stock8*.test + - touch generic/tclStubInit.c generic/tclOOStubInit.c generic/tclOOScript.h - cd ${BUILD_DIR} install: - mkdir "$HOME/install dir" @@ -457,6 +458,6 @@ install: before_script: - export ERROR_ON_FAILURES=1 script: - - make all tcltest + - make all tcltest || echo "Something wrong, maybe a hickup, let's try again" - make test - make install diff --git a/ChangeLog.2001 b/ChangeLog.2001 index 06e7c36..9d6d541 100644 --- a/ChangeLog.2001 +++ b/ChangeLog.2001 @@ -351,7 +351,7 @@ * mac/tclMacFile.c: fixed bug in permission checking code - * mac/tclMacLoad.c: corrected utf8 handling, comparison of package + * mac/tclMacLoad.c: corrected utf-8 handling, comparison of package names to code fragment names changed to only match on the length of package name, this allows for fragment names with version numbers appended. diff --git a/ChangeLog.2002 b/ChangeLog.2002 index 9931657..fa31e42 100644 --- a/ChangeLog.2002 +++ b/ChangeLog.2002 @@ -1753,7 +1753,7 @@ 2002-07-05 Reinhard Max <max@suse.de> - * generic/tclClock.c (FormatClock): Convert the format string to UTF8 + * generic/tclClock.c (FormatClock): Convert the format string to utf-8 before calling TclpStrftime, so that non-ASCII characters don't get mangled when the result string is being converted back. * tests/clock.test: Added a test for that. diff --git a/ChangeLog.2004 b/ChangeLog.2004 index daf124f..f7da18d 100644 --- a/ChangeLog.2004 +++ b/ChangeLog.2004 @@ -2302,7 +2302,7 @@ 934511]. * doc/CrtCommand.3: Added note that the arguments given to the command - proc of a Tcl_CreateCommand are in utf8 since Tcl 8.1. Closing [Patch + proc of a Tcl_CreateCommand are in utf-8 since Tcl 8.1. Closing [Patch 414778]. * doc/ChnlStack.3: Removed the declaration that the interp argument to @@ -2873,7 +2873,7 @@ 2004-06-02 Jeff Hobbs <jeffh@ActiveState.com> * win/tclWinFile.c (TclpFindExecutable): when using GetModuleFileNameA - (Win9x), convert from CP_ACP to WCHAR then convert back to utf8. + (Win9x), convert from CP_ACP to WCHAR then convert back to utf-8. Adjunct to 2004-04-07 fix. 2004-06-02 David Gravereaux <davygrvy@pobox.com> diff --git a/compat/string.h b/compat/string.h index 42be10c..aa889f2 100644 --- a/compat/string.h +++ b/compat/string.h @@ -21,19 +21,15 @@ #include <sys/types.h> -#ifdef __APPLE__ extern void * memchr(const void *s, int c, size_t n); -#else -extern char * memchr(const void *s, int c, size_t n); -#endif extern int memcmp(const void *s1, const void *s2, size_t n); -extern char * memcpy(void *t, const void *f, size_t n); +extern void * memcpy(void *t, const void *f, size_t n); #ifdef NO_MEMMOVE #define memmove(d,s,n) (bcopy((s), (d), (n))) #else extern char * memmove(void *t, const void *f, size_t n); #endif -extern char * memset(void *s, int c, size_t n); +extern void * memset(void *s, int c, size_t n); extern int strcasecmp(const char *s1, const char *s2); extern char * strcat(char *dst, const char *src); diff --git a/doc/CrtAlias.3 b/doc/CrtAlias.3 index 10192e9..92f9b0c 100644 --- a/doc/CrtAlias.3 +++ b/doc/CrtAlias.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateSlave, Tcl_GetSlave, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands +Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateChild, Tcl_CreateSlave, Tcl_GetChild, Tcl_GetSlave, Tcl_GetParent, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -20,31 +20,40 @@ int \fBTcl_MakeSafe\fR(\fIinterp\fR) .sp Tcl_Interp * +\fBTcl_CreateChild\fR(\fIinterp, name, isSafe\fR) +.sp +Tcl_Interp * \fBTcl_CreateSlave\fR(\fIinterp, name, isSafe\fR) .sp Tcl_Interp * \fBTcl_GetSlave\fR(\fIinterp, name\fR) .sp Tcl_Interp * +\fBTcl_GetChild\fR(\fIinterp, name\fR) +.sp +Tcl_Interp * \fBTcl_GetMaster\fR(\fIinterp\fR) .sp +Tcl_Interp * +\fBTcl_GetParent\fR(\fIinterp\fR) +.sp int -\fBTcl_GetInterpPath\fR(\fIinterp, slaveInterp\fR) +\fBTcl_GetInterpPath\fR(\fIinterp, childInterp\fR) .sp int -\fBTcl_CreateAlias\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd, +\fBTcl_CreateAlias\fR(\fIchildInterp, childCmd, targetInterp, targetCmd, argc, argv\fR) .sp int -\fBTcl_CreateAliasObj\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd, +\fBTcl_CreateAliasObj\fR(\fIchildInterp, childCmd, targetInterp, targetCmd, objc, objv\fR) .sp int -\fBTcl_GetAlias\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr, +\fBTcl_GetAlias\fR(\fIinterp, childCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr\fR) .sp int -\fBTcl_GetAliasObj\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr, +\fBTcl_GetAliasObj\fR(\fIinterp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objvPtr\fR) .sp int @@ -57,16 +66,16 @@ int .AP Tcl_Interp *interp in Interpreter in which to execute the specified command. .AP "const char" *name in -Name of slave interpreter to create or manipulate. +Name of child interpreter to create or manipulate. .AP int isSafe in If non-zero, a .QW safe -slave that is suitable for running untrusted code -is created, otherwise a trusted slave is created. -.AP Tcl_Interp *slaveInterp in +child that is suitable for running untrusted code +is created, otherwise a trusted child is created. +.AP Tcl_Interp *childInterp in Interpreter to use for creating the source command for an alias (see below). -.AP "const char" *slaveCmd in +.AP "const char" *childCmd in Name of source command for alias. .AP Tcl_Interp *targetInterp in Interpreter that contains the target command for an alias. @@ -121,17 +130,19 @@ interpreter. The return value for those procedures that return an \fBint\fR is either \fBTCL_OK\fR or \fBTCL_ERROR\fR. If \fBTCL_ERROR\fR is returned then the interpreter's result contains an error message. .PP -\fBTcl_CreateSlave\fR creates a new interpreter as a slave of \fIinterp\fR. -It also creates a slave command named \fIslaveName\fR in \fIinterp\fR which -allows \fIinterp\fR to manipulate the new slave. -If \fIisSafe\fR is zero, the command creates a trusted slave in which Tcl +\fBTcl_CreateChild\fR creates a new interpreter as a child of \fIinterp\fR. +It also creates a child command named \fIname\fR in \fIinterp\fR which +allows \fIinterp\fR to manipulate the new child. +If \fIisSafe\fR is zero, the command creates a trusted child in which Tcl code has access to all the Tcl commands. If it is \fB1\fR, the command creates a .QW safe -slave in which Tcl code has access only to set of Tcl commands defined as +child in which Tcl code has access only to set of Tcl commands defined as .QW "Safe Tcl" ; see the manual entry for the Tcl \fBinterp\fR command for details. -If the creation of the new slave interpreter failed, \fBNULL\fR is returned. +If the creation of the new child interpreter failed, \fBNULL\fR is returned. +.PP +\fBTcl_CreateSlave\fR is a synonym for \fBTcl_CreateChild\fR. .PP \fBTcl_IsSafe\fR returns \fB1\fR if \fIinterp\fR is .QW safe @@ -147,34 +158,38 @@ from \fIinterp\fR. However, it cannot know what parts of an extension or application are safe and does not make any attempt to remove those parts, so safety is not guaranteed after calling \fBTcl_MakeSafe\fR. Callers will want to take care with their use of \fBTcl_MakeSafe\fR -to avoid false claims of safety. For many situations, \fBTcl_CreateSlave\fR +to avoid false claims of safety. For many situations, \fBTcl_CreateChild\fR may be a better choice, since it creates interpreters in a known-safe state. .PP -\fBTcl_GetSlave\fR returns a pointer to a slave interpreter of -\fIinterp\fR. The slave interpreter is identified by \fIslaveName\fR. -If no such slave interpreter exists, \fBNULL\fR is returned. +\fBTcl_GetChild\fR returns a pointer to a child interpreter of +\fIinterp\fR. The child interpreter is identified by \fIname\fR. +If no such child interpreter exists, \fBNULL\fR is returned. .PP -\fBTcl_GetMaster\fR returns a pointer to the master interpreter of -\fIinterp\fR. If \fIinterp\fR has no master (it is a +\fBTcl_GetSlave\fR is a synonym for \fBTcl_GetChild\fR. +.PP +\fBTcl_GetParent\fR returns a pointer to the parent interpreter of +\fIinterp\fR. If \fIinterp\fR has no parent (it is a top-level interpreter) then \fBNULL\fR is returned. .PP +\fBTcl_GetMaster\fR is a synonym for \fBTcl_GetParent\fR. +.PP \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 +the relative path between \fIinterp\fR and \fIchildInterp\fR; +\fIchildInterp\fR must be a child 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 \fIinterp\fR. .PP -\fBTcl_CreateAlias\fR creates a command named \fIslaveCmd\fR in -\fIslaveInterp\fR that when invoked, will cause the command \fItargetCmd\fR +\fBTcl_CreateAlias\fR creates a command named \fIchildCmd\fR in +\fIchildInterp\fR that when invoked, will cause the command \fItargetCmd\fR to be invoked in \fItargetInterp\fR. The arguments specified by the strings contained in \fIargv\fR are always prepended to any arguments supplied in the -invocation of \fIslaveCmd\fR and passed to \fItargetCmd\fR. +invocation of \fIchildCmd\fR and passed to \fItargetCmd\fR. This operation returns \fBTCL_OK\fR if it succeeds, or \fBTCL_ERROR\fR if it fails; in that case, an error message is left in the value result -of \fIslaveInterp\fR. +of \fIchildInterp\fR. Note that there are no restrictions on the ancestry relationship (as -created by \fBTcl_CreateSlave\fR) between \fIslaveInterp\fR and +created by \fBTcl_CreateChild\fR) between \fIchildInterp\fR and \fItargetInterp\fR. Any two interpreters can be used, without any restrictions on how they are related. .PP @@ -233,4 +248,4 @@ interp .SH KEYWORDS alias, command, exposed commands, hidden commands, interpreter, invoke, -master, slave +parent, child diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index 3b50232..4e77114 100644 --- a/doc/FileSystem.3 +++ b/doc/FileSystem.3 @@ -414,7 +414,7 @@ caller (with a reference count of 0). the encoding identified by \fIencodingName\fR and evaluates its contents as a Tcl script. It returns the same information as \fBTcl_EvalObjEx\fR. -If \fIencodingName\fR is NULL, the system encoding is used for +If \fIencodingName\fR is NULL, the utf-8 encoding is used for reading the file contents. If the file could not be read then a Tcl error is returned to describe why the file could not be read. @@ -430,7 +430,7 @@ or which will be safely substituted by the Tcl interpreter into .QW ^Z . \fBTcl_FSEvalFile\fR is a simpler version of -\fBTcl_FSEvalFileEx\fR that always uses the system encoding +\fBTcl_FSEvalFileEx\fR that always uses the utf-8 encoding when reading the file. .PP \fBTcl_FSLoadFile\fR dynamically loads a binary code file into memory and @@ -1340,11 +1340,11 @@ is considered to be owned by the filesystem (not by Tcl's core), but should be given a reference count for Tcl. Tcl will use the contents of the list and then decrement that reference count. This allows filesystems to choose whether they actually want to retain a -.QW "master list" +.QW "global list" of volumes or not (if not, they generate the list on the fly and pass it to Tcl with a reference count of 1 and then forget about the list, if yes, then -they simply increment the reference count of their master list and pass it +they simply increment the reference count of their global list and pass it to Tcl which will copy the contents and then decrement the count back to where it was). .PP diff --git a/doc/GetIndex.3 b/doc/GetIndex.3 index 17a31d4..8591c56 100644 --- a/doc/GetIndex.3 +++ b/doc/GetIndex.3 @@ -27,19 +27,22 @@ Interpreter to use for error reporting; if NULL, then no message is provided on errors. .AP Tcl_Obj *objPtr in/out The string value of this value is used to search through \fItablePtr\fR. -The internal representation is modified to hold the index of the matching +If the \fBTCL_INDEX_TEMP_TABLE\fR flag is not specified, +the internal representation is modified to hold the index of the matching table entry. .AP "const char *const" *tablePtr in An array of null-terminated strings. The end of the array is marked by a NULL string pointer. -Note that references to the \fItablePtr\fR may be retained in the +Note that, unless the \fBTCL_INDEX_TEMP_TABLE\fR flag is specified, +references to the \fItablePtr\fR may be retained in the internal representation of \fIobjPtr\fR, so this should represent the address of a statically-allocated array. .AP "const void" *structTablePtr in An array of arbitrary type, typically some \fBstruct\fR type. The first member of the structure must be a null-terminated string. The size of the structure is given by \fIoffset\fR. -Note that references to the \fIstructTablePtr\fR may be retained in the +Note that, unless the \fBTCL_INDEX_TEMP_TABLE\fR flag is specified, +references to the \fIstructTablePtr\fR may be retained in the internal representation of \fIobjPtr\fR, so this should represent the address of a statically-allocated array of structures. .AP int offset in @@ -50,7 +53,8 @@ Null-terminated string describing what is being looked up, such as \fBoption\fR. This string is included in error messages. .AP int flags in OR-ed combination of bits providing additional information for -operation. The only bit that is currently defined is \fBTCL_EXACT\fR. +operation. The only bits that are currently defined are \fBTCL_EXACT\fR +and \fBTCL_INDEX_TEMP_TABLE\fR. .AP int *indexPtr out The index of the string in \fItablePtr\fR that matches the value of \fIobjPtr\fR is returned here. @@ -76,7 +80,8 @@ error message to indicate what was being looked up. For example, if \fImsg\fR is \fBoption\fR the error message will have a form like .QW "\fBbad option \N'34'firt\N'34': must be first, second, or third\fR" . .PP -If \fBTcl_GetIndexFromObj\fR completes successfully it modifies the +If the \fBTCL_INDEX_TEMP_TABLE\fR was not specified, when +\fBTcl_GetIndexFromObj\fR completes successfully it modifies the internal representation of \fIobjPtr\fR to hold the address of the table and the index of the matching entry. If \fBTcl_GetIndexFromObj\fR is invoked again with the same \fIobjPtr\fR and \fItablePtr\fR @@ -84,7 +89,9 @@ arguments (e.g. during a reinvocation of a Tcl command), it returns the matching index immediately without having to redo the lookup operation. Note: \fBTcl_GetIndexFromObj\fR assumes that the entries in \fItablePtr\fR are static: they must not change between -invocations. If the value of \fIobjPtr\fR is the empty string, +invocations. This caching mechanism can be disallowed by specifying +the \fBTCL_INDEX_TEMP_TABLE\fR flag. +If the value of \fIobjPtr\fR is the empty string, \fBTcl_GetIndexFromObj\fR will treat it as a non-matching value and return \fBTCL_ERROR\fR. .PP diff --git a/doc/Limit.3 b/doc/Limit.3 index 5939a80..3d202fc 100644 --- a/doc/Limit.3 +++ b/doc/Limit.3 @@ -116,7 +116,7 @@ execution of the callbacks is unspecified) execution in the limited interpreter is stopped by raising an error and setting a flag that prevents the \fBcatch\fR command in that interpreter from trapping that error. It is up to the context that started execution in that -interpreter (typically a master interpreter) to handle the error. +interpreter (typically the main interpreter) to handle the error. .SH "LIMIT CHECKING API" .PP To check the resource limits for an interpreter, call diff --git a/doc/Tcl_Main.3 b/doc/Tcl_Main.3 index dc4f45f..62ceeab 100644 --- a/doc/Tcl_Main.3 +++ b/doc/Tcl_Main.3 @@ -79,7 +79,7 @@ against the standard Tcl library. Extensions (stub-enabled or not) are not intended to call \fBTcl_Main\fR. .PP \fBTcl_Main\fR is not thread-safe. It should only be called by -a single master thread of a multi-threaded application. This +a single main thread of a multi-threaded application. This restriction is not a problem with normal use described above. .PP \fBTcl_Main\fR and therefore all applications based upon it, like @@ -112,7 +112,7 @@ The file name and encoding values managed by the routines \fBTcl_SetStartupScript\fR and \fBTcl_GetStartupScript\fR are stored per-thread. Although the storage and retrieval functions of these routines work in any thread, only those -calls in the same master thread as \fBTcl_Main\fR can have +calls in the same main thread as \fBTcl_Main\fR can have any influence on it. .PP The caller of \fBTcl_Main\fR may call \fBTcl_SetStartupScript\fR @@ -126,7 +126,7 @@ a \fIstartup script\fR, and \fIname\fR is taken to be the name of the encoding of the contents of that file. \fBTcl_Main\fR then calls \fBTcl_SetStartupScript\fR with these values. .PP -\fBTcl_Main\fR then defines in its master interpreter +\fBTcl_Main\fR then defines in its main interpreter the Tcl variables \fIargc\fR, \fIargv\fR, \fIargv0\fR, and \fItcl_interactive\fR, as described in the documentation for \fBtclsh\fR. .PP @@ -154,9 +154,9 @@ When the \fIappInitProc\fR is finished, \fBTcl_Main\fR calls been requested, if any. If a startup script has been provided, \fBTcl_Main\fR attempts to evaluate it. Otherwise, interactive mode begins with examination of the variable \fItcl_rcFileName\fR -in the master interpreter. If that variable exists and holds the +in the main interpreter. If that variable exists and holds the name of a readable file, the contents of that file are evaluated -in the master interpreter. Then interactive operations begin, +in the main interpreter. Then interactive operations begin, with prompts and command evaluation results written to the standard output channel, and commands read from the standard input channel and then evaluated. The prompts written to the standard output @@ -164,7 +164,7 @@ channel may be customized by defining the Tcl variables \fItcl_prompt1\fR and \fItcl_prompt2\fR as described in the documentation for \fBtclsh\fR. The prompts and command evaluation results are written to the standard output channel only if the Tcl variable \fItcl_interactive\fR in the -master interpreter holds a non-zero integer value. +main interpreter holds a non-zero integer value. .PP \fBTcl_SetMainLoop\fR allows setting an event loop procedure to be run. This allows, for example, Tk to be dynamically loaded and set its event @@ -772,7 +772,7 @@ set offset 0 \fI# Search for string "FOOBAR" in the file\fR while {[\fBchan gets\fR $f line] >= 0} { set idx [string first FOOBAR $line] - if {$idx > -1} { + if {$idx >= 0} { \fI# Found it; rewrite line\fR \fBchan seek\fR $f [expr {$offset + $idx}] @@ -259,6 +259,10 @@ proc httpHandlerCallback {socket token} { return $nbytes } .CE +.PP +The \fBhttp::geturl\fR code for the \fB-handler\fR option is not compatible with either compression or chunked transfer-encoding. If \fB-handler\fR is specified, then to work around these issues \fBhttp::geturl\fR will reduce the HTTP protocol to 1.0, and override the \fB-zip\fR option (i.e. it will not send the header "\fBAccept-Encoding: gzip,deflate,compress\fR"). +.PP +If options \fB-handler\fR and \fB-channel\fR are used together, the handler is responsible for copying the data from the HTTP socket to the specified channel. The name of the channel is available to the handler as element \fB-channel\fR of the token array. .RE .TP \fB\-headers\fR \fIkeyvaluelist\fR diff --git a/doc/interp.n b/doc/interp.n index 54555e3..2943404 100644 --- a/doc/interp.n +++ b/doc/interp.n @@ -19,18 +19,18 @@ interp \- Create and manipulate Tcl interpreters .PP This command makes it possible to create one or more new Tcl interpreters that co-exist with the creating interpreter in the -same application. The creating interpreter is called the \fImaster\fR -and the new interpreter is called a \fIslave\fR. -A master can create any number of slaves, and each slave can -itself create additional slaves for which it is master, resulting +same application. The creating interpreter is called the \fIparent\fR +and the new interpreter is called a \fIchild\fR. +A parent can create any number of children, and each child can +itself create additional children for which it is parent, resulting in a hierarchy of interpreters. .PP Each interpreter is independent from the others: it has its own name space for commands, procedures, and global variables. -A master interpreter may create connections between its slaves and +A parent interpreter may create connections between its children and itself using a mechanism called an \fIalias\fR. An \fIalias\fR is -a command in a slave interpreter which, when invoked, causes a -command to be invoked in its master interpreter or in another slave +a command in a child interpreter which, when invoked, causes a +command to be invoked in its parent interpreter or in another child interpreter. The only other connections between interpreters are through environment variables (the \fBenv\fR variable), which are normally shared among all interpreters in the application, @@ -41,7 +41,7 @@ share files and to transfer references to open files from one interpreter to another. .PP The \fBinterp\fR command also provides support for \fIsafe\fR -interpreters. A safe interpreter is a slave whose functions have +interpreters. A safe interpreter is a child whose functions have been greatly restricted, so that it is safe to execute untrusted scripts without fear of them damaging other interpreters or the application's environment. For example, all IO channel creation @@ -54,18 +54,18 @@ instead, it is \fIhidden\fR, so that only trusted interpreters can obtain access to it. For a detailed explanation of hidden commands, see \fBHIDDEN COMMANDS\fR, below. The alias mechanism can be used for protected communication (analogous to a -kernel call) between a slave interpreter and its master. +kernel call) between a child interpreter and its parent. See \fBALIAS INVOCATION\fR, below, for more details on how the alias mechanism works. .PP -A qualified interpreter name is a proper Tcl lists containing a subset of its +A qualified interpreter name is a proper Tcl list containing a subset of its ancestors in the interpreter hierarchy, terminated by the string naming the -interpreter in its immediate master. Interpreter names are relative to the +interpreter in its immediate parent. Interpreter names are relative to the interpreter in which they are used. For example, if .QW \fBa\fR -is a slave of the current interpreter and it has a slave +is a child of the current interpreter and it has a child .QW \fBa1\fR , -which in turn has a slave +which in turn has a child .QW \fBa11\fR , the qualified name of .QW \fBa11\fR @@ -77,14 +77,14 @@ is the list The \fBinterp\fR command, described below, accepts qualified interpreter names as arguments; the interpreter in which the command is being evaluated can always be referred to as \fB{}\fR (the empty list or string). Note that -it is impossible to refer to a master (ancestor) interpreter by name in a -slave interpreter except through aliases. Also, there is no global name by +it is impossible to refer to a parent (ancestor) interpreter by name in a +child interpreter except through aliases. Also, there is no global name by which one can refer to the first interpreter created in an application. Both restrictions are motivated by safety concerns. .SH "THE INTERP COMMAND" .PP The \fBinterp\fR command is used to create, delete, and manipulate -slave interpreters, and to share or transfer +child interpreters, and to share or transfer channels between interpreters. It can have any of several forms, depending on the \fIsubcommand\fR argument: .TP @@ -94,11 +94,11 @@ Returns a Tcl list whose elements are the \fItargetCmd\fR and \fIarg\fRs associated with the alias represented by \fIsrcToken\fR (this is the value returned when the alias was created; it is possible that the name of the source command in the -slave is different from \fIsrcToken\fR). +child is different from \fIsrcToken\fR). .TP \fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcToken\fR \fB{}\fR . -Deletes the alias for \fIsrcToken\fR in the slave interpreter identified by +Deletes the alias for \fIsrcToken\fR in the child interpreter identified by \fIsrcPath\fR. \fIsrcToken\fR refers to the value returned when the alias was created; if the source command has been renamed, the renamed @@ -106,9 +106,9 @@ command will be deleted. .TP \fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcCmd\fR \fItargetPath\fR \fItargetCmd \fR?\fIarg arg ...\fR? . -This command creates an alias between one slave and another (see the -\fBalias\fR slave command below for creating aliases between a slave -and its master). In this command, either of the slave interpreters +This command creates an alias between one child and another (see the +\fBalias\fR child command below for creating aliases between a child +and its parent). In this command, either of the child interpreters may be anywhere in the hierarchy of interpreters under the interpreter invoking the command. \fISrcPath\fR and \fIsrcCmd\fR identify the source of the alias. @@ -117,9 +117,9 @@ interpreter. For example, .QW "\fBa b\fR" identifies an interpreter .QW \fBb\fR , -which is a slave of interpreter +which is a child of interpreter .QW \fBa\fR , -which is a slave of the invoking interpreter. An empty list specifies +which is a child of the invoking interpreter. An empty list specifies the interpreter invoking the command. \fIsrcCmd\fR gives the name of a new command, which will be created in the source interpreter. \fITargetPath\fR and \fItargetCmd\fR specify a target interpreter @@ -169,33 +169,33 @@ used. .TP \fBinterp\fR \fBcreate \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? . -Creates a slave interpreter identified by \fIpath\fR and a new command, -called a \fIslave command\fR. The name of the slave command is the last -component of \fIpath\fR. The new slave interpreter and the slave command +Creates a child interpreter identified by \fIpath\fR and a new command, +called a \fIchild command\fR. The name of the child command is the last +component of \fIpath\fR. The new child interpreter and the child command are created in the interpreter identified by the path obtained by removing the last component from \fIpath\fR. For example, if \fIpath\fR is \fBa b -c\fR then a new slave interpreter and slave command named \fBc\fR are +c\fR then a new child interpreter and child command named \fBc\fR are created in the interpreter identified by the path \fBa b\fR. -The slave command may be used to manipulate the new interpreter as +The child command may be used to manipulate the new interpreter as described below. If \fIpath\fR is omitted, Tcl creates a unique name of the form \fBinterp\fIx\fR, where \fIx\fR is an integer, and uses it for the -interpreter and the slave command. If the \fB\-safe\fR switch is specified -(or if the master interpreter is a safe interpreter), the new slave +interpreter and the child command. If the \fB\-safe\fR switch is specified +(or if the parent interpreter is a safe interpreter), the new child interpreter will be created as a safe interpreter with limited -functionality; otherwise the slave will include the full set of Tcl +functionality; otherwise the child will include the full set of Tcl built-in commands and variables. The \fB\-\|\-\fR switch can be used to mark the end of switches; it may be needed if \fIpath\fR is an unusual value such as \fB\-safe\fR. The result of the command is the name of the -new interpreter. The name of a slave interpreter must be unique among all -the slaves for its master; an error occurs if a slave interpreter by the -given name already exists in this master. -The initial recursion limit of the slave interpreter is set to the +new interpreter. The name of a child interpreter must be unique among all +the children for its parent; an error occurs if a child interpreter by the +given name already exists in this parent. +The initial recursion limit of the child interpreter is set to the current recursion limit of its parent interpreter. .TP \fBinterp\fR \fBdebug \fIpath\fR ?\fB\-frame\fR ?\fIbool\fR?? . Controls whether frame-level stack information is captured in the -slave interpreter identified by \fIpath\fR. If no arguments are +child interpreter identified by \fIpath\fR. If no arguments are given, option and current setting are returned. If \fB\-frame\fR is given, the debug setting is set to the given boolean if provided and the current setting is returned. @@ -237,8 +237,8 @@ consistency of the underlying interpreter's state. \fBinterp\fR \fBdelete \fR?\fIpath ...\fR? . Deletes zero or more interpreters given by the optional \fIpath\fR -arguments, and for each interpreter, it also deletes its slaves. The -command also deletes the slave command for each interpreter deleted. +arguments, and for each interpreter, it also deletes its children. The +command also deletes the child command for each interpreter deleted. For each \fIpath\fR argument, if no interpreter by that name exists, the command raises an error. .TP @@ -246,20 +246,20 @@ exists, the command raises an error. . This command concatenates all of the \fIarg\fR arguments in the same fashion as the \fBconcat\fR command, then evaluates the resulting string as -a Tcl script in the slave interpreter identified by \fIpath\fR. The result +a Tcl script in the child interpreter identified by \fIpath\fR. The result of this evaluation (including all \fBreturn\fR options, such as \fB\-errorinfo\fR and \fB\-errorcode\fR information, if an error occurs) is returned to the invoking interpreter. Note that the script will be executed in the current context stack frame of the -\fIpath\fR interpreter; this is so that the implementations (in a master -interpreter) of aliases in a slave interpreter can execute scripts in -the slave that find out information about the slave's current state +\fIpath\fR interpreter; this is so that the implementations (in a parent +interpreter) of aliases in a child interpreter can execute scripts in +the child that find out information about the child's current state and stack frame. .TP \fBinterp exists \fIpath\fR . -Returns \fB1\fR if a slave interpreter by the specified \fIpath\fR -exists in this master, \fB0\fR otherwise. If \fIpath\fR is omitted, the +Returns \fB1\fR if a child interpreter by the specified \fIpath\fR +exists in this parent, \fB0\fR otherwise. If \fIpath\fR is omitted, the invoking interpreter is used. .TP \fBinterp expose \fIpath\fR \fIhiddenName\fR ?\fIexposedCmdName\fR? @@ -285,7 +285,7 @@ Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can not contain namespace qualifiers, or an error is raised. Commands to be hidden by \fBinterp hide\fR are looked up in the global namespace even if the current namespace is not the global one. This -prevents slaves from fooling a master interpreter into hiding the wrong +prevents children from fooling a parent interpreter into hiding the wrong command, by making the current namespace be different from the global one. Hidden commands are explained in more detail in \fBHIDDEN COMMANDS\fR, below. .TP @@ -369,12 +369,16 @@ Both interpreters must close it to close the underlying IO channel; IO channels accessible in an interpreter are automatically closed when an interpreter is destroyed. .TP -\fBinterp\fR \fBslaves\fR ?\fIpath\fR? +\fBinterp\fR \fBchildren\fR ?\fIpath\fR? . -Returns a Tcl list of the names of all the slave interpreters associated +Returns a Tcl list of the names of all the child interpreters associated with the interpreter identified by \fIpath\fR. If \fIpath\fR is omitted, the invoking interpreter is used. .TP +\fBinterp\fR \fBslaves\fR ?\fIpath\fR? +. +Synonym for . \fBinterp\fR \fBchildren\fR ?\fIpath\fR? +.TP \fBinterp\fR \fBtarget\fR \fIpath alias\fR . Returns a Tcl list describing the target interpreter for an alias. The @@ -391,48 +395,48 @@ The target command does not have to be defined at the time of this invocation. Causes the IO channel identified by \fIchannelId\fR to become available in the interpreter identified by \fIdestPath\fR and unavailable in the interpreter identified by \fIsrcPath\fR. -.SH "SLAVE COMMAND" +.SH "CHILD COMMAND" .PP -For each slave interpreter created with the \fBinterp\fR command, a -new Tcl command is created in the master interpreter with the same +For each child interpreter created with the \fBinterp\fR command, a +new Tcl command is created in the parent interpreter with the same name as the new interpreter. This command may be used to invoke various operations on the interpreter. It has the following general form: .PP .CS -\fIslave command \fR?\fIarg arg ...\fR? +\fIchild command \fR?\fIarg arg ...\fR? .CE .PP -\fISlave\fR is the name of the interpreter, and \fIcommand\fR +\fIChild\fR is the name of the interpreter, and \fIcommand\fR and the \fIarg\fRs determine the exact behavior of the command. The valid forms of this command are: .TP -\fIslave \fBaliases\fR +\fIchild \fBaliases\fR . Returns a Tcl list whose elements are the tokens of all the -aliases in \fIslave\fR. The tokens correspond to the values returned when +aliases in \fIchild\fR. The tokens correspond to the values returned when the aliases were created (which may not be the same as the current names of the commands). .TP -\fIslave \fBalias \fIsrcToken\fR +\fIchild \fBalias \fIsrcToken\fR . Returns a Tcl list whose elements are the \fItargetCmd\fR and \fIarg\fRs associated with the alias represented by \fIsrcToken\fR (this is the value returned when the alias was created; it is possible that the actual source command in the -slave is different from \fIsrcToken\fR). +child is different from \fIsrcToken\fR). .TP -\fIslave \fBalias \fIsrcToken \fB{}\fR +\fIchild \fBalias \fIsrcToken \fB{}\fR . -Deletes the alias for \fIsrcToken\fR in the slave interpreter. +Deletes the alias for \fIsrcToken\fR in the child interpreter. \fIsrcToken\fR refers to the value returned when the alias was created; if the source command has been renamed, the renamed command will be deleted. .TP -\fIslave \fBalias \fIsrcCmd targetCmd \fR?\fIarg ..\fR? +\fIchild \fBalias \fIsrcCmd targetCmd \fR?\fIarg ..\fR? . Creates an alias such that whenever \fIsrcCmd\fR is invoked -in \fIslave\fR, \fItargetCmd\fR is invoked in the master. +in \fIchild\fR, \fItargetCmd\fR is invoked in the parent. The \fIarg\fR arguments will be passed to \fItargetCmd\fR as additional arguments, prepended before any arguments passed in the invocation of \fIsrcCmd\fR. @@ -441,69 +445,69 @@ The command returns a token that uniquely identifies the command created \fIsrcCmd\fR, even if the command is renamed afterwards. The token may but does not have to be equal to \fIsrcCmd\fR. .TP -\fIslave \fBbgerror\fR ?\fIcmdPrefix\fR? +\fIchild \fBbgerror\fR ?\fIcmdPrefix\fR? . This command either gets or sets the current background exception handler -for the \fIslave\fR interpreter. If \fIcmdPrefix\fR is +for the \fIchild\fR interpreter. If \fIcmdPrefix\fR is absent, the current background exception handler is returned, and if it is present, it is a list of words (of minimum length one) that describes what to set the interpreter's background exception handler to. See the \fBBACKGROUND EXCEPTION HANDLING\fR section for more details. .TP -\fIslave \fBeval \fIarg \fR?\fIarg ..\fR? +\fIchild \fBeval \fIarg \fR?\fIarg ..\fR? . This command concatenates all of the \fIarg\fR arguments in the same fashion as the \fBconcat\fR command, then evaluates -the resulting string as a Tcl script in \fIslave\fR. +the resulting string as a Tcl script in \fIchild\fR. The result of this evaluation (including all \fBreturn\fR options, such as \fB\-errorinfo\fR and \fB\-errorcode\fR information, if an error occurs) is returned to the invoking interpreter. Note that the script will be executed in the current context stack frame -of \fIslave\fR; this is so that the implementations (in a master -interpreter) of aliases in a slave interpreter can execute scripts in -the slave that find out information about the slave's current state +of \fIchild\fR; this is so that the implementations (in a parent +interpreter) of aliases in a child interpreter can execute scripts in +the child that find out information about the child's current state and stack frame. .TP -\fIslave \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR? +\fIchild \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR? . This command exposes the hidden command \fIhiddenName\fR, eventually bringing it back under a new \fIexposedCmdName\fR name (this name is currently accepted only if it is a valid global name space name without any ::), -in \fIslave\fR. +in \fIchild\fR. If an exposed command with the targeted name already exists, this command fails. For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below. .TP -\fIslave \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR? +\fIchild \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR? . This command hides the exposed command \fIexposedCmdName\fR, renaming it to the hidden command \fIhiddenCmdName\fR, or keeping the same name if the -argument is not given, in the \fIslave\fR interpreter. +argument is not given, in the \fIchild\fR interpreter. If a hidden command with the targeted name already exists, this command fails. Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can not contain namespace qualifiers, or an error is raised. Commands to be hidden are looked up in the global namespace even if the current namespace is not the global one. This -prevents slaves from fooling a master interpreter into hiding the wrong +prevents children from fooling a parent interpreter into hiding the wrong command, by making the current namespace be different from the global one. For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below. .TP -\fIslave \fBhidden\fR +\fIchild \fBhidden\fR . -Returns a list of the names of all hidden commands in \fIslave\fR. +Returns a list of the names of all hidden commands in \fIchild\fR. .TP -\fIslave \fBinvokehidden\fR ?\fI\-option ...\fR? \fIhiddenName \fR?\fIarg ..\fR? +\fIchild \fBinvokehidden\fR ?\fI\-option ...\fR? \fIhiddenName \fR?\fIarg ..\fR? . This command invokes the hidden command \fIhiddenName\fR with the -supplied arguments, in \fIslave\fR. No substitutions or evaluations are +supplied arguments, in \fIchild\fR. No substitutions or evaluations are applied to the arguments. Three \fI\-option\fRs are supported, all of which start with \fB\-\fR: \fB\-namespace\fR (which takes a single argument afterwards, \fInsName\fR), \fB\-global\fR, and \fB\-\|\-\fR. If the \fB\-namespace\fR flag is given, the hidden command is invoked in -the specified namespace in the slave. +the specified namespace in the child. If the \fB\-global\fR flag is given, the command is invoked at the global -level in the slave; otherwise it is invoked at the current call frame and +level in the child; otherwise it is invoked at the current call frame and can access local variables in that or outer call frames. The \fB\-\|\-\fR flag allows the \fIhiddenCmdName\fR argument to start with a .QW \- @@ -511,37 +515,37 @@ character, and is otherwise unnecessary. If both the \fB\-namespace\fR and \fB\-global\fR flags are given, the \fB\-namespace\fR flag is ignored. Note that the hidden command will be executed (by default) in the -current context stack frame of \fIslave\fR. +current context stack frame of \fIchild\fR. For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below. .TP -\fIslave \fBissafe\fR +\fIchild \fBissafe\fR . -Returns \fB1\fR if the slave interpreter is safe, \fB0\fR otherwise. +Returns \fB1\fR if the child interpreter is safe, \fB0\fR otherwise. .TP -\fIslave \fBlimit\fR \fIlimitType\fR ?\fI\-option\fR? ?\fIvalue\fR \fI...\fR? +\fIchild \fBlimit\fR \fIlimitType\fR ?\fI\-option\fR? ?\fIvalue\fR \fI...\fR? . Sets up, manipulates and queries the configuration of the resource -limit \fIlimitType\fR for the slave interpreter. If no \fI\-option\fR +limit \fIlimitType\fR for the child interpreter. If no \fI\-option\fR is specified, return the current configuration of the limit. If \fI\-option\fR is the sole argument, return the value of that option. Otherwise, a list of \fI\-option\fR/\fIvalue\fR argument pairs must supplied. See \fBRESOURCE LIMITS\fR below for a more detailed explanation of what limits and options are supported. .TP -\fIslave \fBmarktrusted\fR +\fIchild \fBmarktrusted\fR . -Marks the slave interpreter as trusted. Can only be invoked by a +Marks the child interpreter as trusted. Can only be invoked by a trusted interpreter. This command does not expose any hidden -commands in the slave interpreter. The command has no effect if the slave +commands in the child interpreter. The command has no effect if the child is already trusted. .TP -\fIslave\fR \fBrecursionlimit\fR ?\fInewlimit\fR? +\fIchild\fR \fBrecursionlimit\fR ?\fInewlimit\fR? . -Returns the maximum allowable nesting depth for the \fIslave\fR interpreter. -If \fInewlimit\fR is specified, the recursion limit in \fIslave\fR will be +Returns the maximum allowable nesting depth for the \fIchild\fR interpreter. +If \fInewlimit\fR is specified, the recursion limit in \fIchild\fR will be set so that nesting of more than \fInewlimit\fR calls to \fBTcl_Eval()\fR -and related procedures in \fIslave\fR will return an error. +and related procedures in \fIchild\fR will return an error. The \fInewlimit\fR value is also returned. The \fInewlimit\fR value must be a positive integer between 1 and the maximum value of a non-long integer on the platform. @@ -565,14 +569,14 @@ For example, commands to create files on disk are removed, and the \fBexec\fR command is removed, since it could be used to cause damage through subprocesses. Limited access to these facilities can be provided, by creating -aliases to the master interpreter which check their arguments carefully +aliases to the parent interpreter which check their arguments carefully and provide restricted access to a safe subset of facilities. For example, file creation might be allowed in a particular subdirectory and subprocess invocation might be allowed for a carefully selected and fixed set of programs. .PP A safe interpreter is created by specifying the \fB\-safe\fR switch -to the \fBinterp create\fR command. Furthermore, any slave created +to the \fBinterp create\fR command. Furthermore, any child created by a safe interpreter will also be safe. .PP A safe interpreter is created with exactly the following set of @@ -659,15 +663,15 @@ including itself. .SH "ALIAS INVOCATION" .PP The alias mechanism has been carefully designed so that it can -be used safely when an untrusted script is executing -in a safe slave and the target of the alias is a trusted -master. The most important thing in guaranteeing safety is to -ensure that information passed from the slave to the master is -never evaluated or substituted in the master; if this were to -occur, it would enable an evil script in the slave to invoke -arbitrary functions in the master, which would compromise security. -.PP -When the source for an alias is invoked in the slave interpreter, the +be used safely in an untrusted script which is being executed in a +safe interpreter even if the target of the alias is not a safe +interpreter. The most important thing in guaranteeing safety is to +ensure that information passed from the child to the parent is +never evaluated or substituted in the parent; if this were to +occur, it would enable an evil script in the child to invoke +arbitrary functions in the parent, which would compromise security. +.PP +When the source for an alias is invoked in the child interpreter, the usual Tcl substitutions are performed when parsing that command. These substitutions are carried out in the source interpreter just as they would be for any other command invoked in that interpreter. @@ -694,8 +698,8 @@ the alias's source command is parsed in the source interpreter. When writing the \fItargetCmd\fRs for aliases in safe interpreters, it is very important that the arguments to that command never be evaluated or substituted, since this would provide an escape -mechanism whereby the slave interpreter could execute arbitrary -code in the master. This in turn would compromise the security +mechanism whereby the child interpreter could execute arbitrary +code in the parent. This in turn would compromise the security of the system. .SH "HIDDEN COMMANDS" .PP @@ -722,28 +726,28 @@ invoke\fR. Hidden commands and exposed commands reside in separate name spaces. It is possible to define a hidden command and an exposed command by the same name within one interpreter. .PP -Hidden commands in a slave interpreter can be invoked in the body of -procedures called in the master during alias invocation. For example, an -alias for \fBsource\fR could be created in a slave interpreter. When it is -invoked in the slave interpreter, a procedure is called in the master +Hidden commands in a child interpreter can be invoked in the body of +procedures called in the parent during alias invocation. For example, an +alias for \fBsource\fR could be created in a child interpreter. When it is +invoked in the child interpreter, a procedure is called in the parent interpreter to check that the operation is allowable (e.g. it asks to -source a file that the slave interpreter is allowed to access). The -procedure then it invokes the hidden \fBsource\fR command in the slave +source a file that the child interpreter is allowed to access). The +procedure then it invokes the hidden \fBsource\fR command in the child interpreter to actually source in the contents of the file. Note that two -commands named \fBsource\fR exist in the slave interpreter: the alias, and +commands named \fBsource\fR exist in the child interpreter: the alias, and the hidden command. .PP -Because a master interpreter may invoke a hidden command as part of +Because a parent interpreter may invoke a hidden command as part of handling an alias invocation, great care must be taken to avoid evaluating any arguments passed in through the alias invocation. -Otherwise, malicious slave interpreters could cause a trusted master +Otherwise, malicious child interpreters could cause a trusted parent interpreter to execute dangerous commands on their behalf. See the section on \fBALIAS INVOCATION\fR for a more complete discussion of this topic. To help avoid this problem, no substitutions or evaluations are applied to arguments of \fBinterp invokehidden\fR. .PP Safe interpreters are not allowed to invoke hidden commands in themselves -or in their descendants. This prevents safe slaves from gaining access to +or in their descendants. This prevents them from gaining access to hidden functionality in themselves or their descendants. .PP The set of hidden commands in an interpreter can be manipulated by a trusted @@ -762,12 +766,12 @@ qualifiers, and you must first rename a command in a namespace to the global namespace before you can hide it. Commands to be hidden by \fBinterp hide\fR are looked up in the global namespace even if the current namespace is not the global one. This -prevents slaves from fooling a master interpreter into hiding the wrong +prevents children from fooling a parent interpreter into hiding the wrong command, by making the current namespace be different from the global one. .SH "RESOURCE LIMITS" .PP Every interpreter has two kinds of resource limits that may be imposed by any -master interpreter upon its slaves. Command limits (of type \fBcommand\fR) +parent interpreter upon its children. Command limits (of type \fBcommand\fR) restrict the total number of Tcl commands that may be executed by an interpreter (as can be inspected via the \fBinfo cmdcount\fR command), and time limits (of type \fBtime\fR) place a limit by which execution within the @@ -776,7 +780,7 @@ interpreter must complete. Note that time limits are expressed as \fBafter\fR) because they may be modified after creation. .PP When a limit is exceeded for an interpreter, first any handler callbacks -defined by master interpreters are called. If those callbacks increase or +defined by parent interpreters are called. If those callbacks increase or remove the limit, execution within the (previously) limited interpreter continues. If the limit is still in force, an error is generated at that point and normal processing of errors within the interpreter (by the \fBcatch\fR @@ -833,13 +837,13 @@ This option specifies the number of commands that the interpreter may execute before triggering the command limit. This option may be the empty string, which indicates that a command limit is not set for the interpreter. .PP -Where an interpreter with a resource limit set on it creates a slave -interpreter, that slave interpreter will have resource limits imposed on it -that are at least as restrictive as the limits on the creating master -interpreter. If the master interpreter of the limited master wishes to relax +Where an interpreter with a resource limit set on it creates a child +interpreter, that child interpreter will have resource limits imposed on it +that are at least as restrictive as the limits on the creating parent +interpreter. If the parent interpreter of the limited parent wishes to relax these conditions, it should hide the \fBinterp\fR command in the child and then use aliases and the \fBinterp invokehidden\fR subcommand to provide such -access as it chooses to the \fBinterp\fR command to the limited master as +access as it chooses to the \fBinterp\fR command to the limited parent as necessary. .SH "BACKGROUND EXCEPTION HANDLING" .PP @@ -900,9 +904,9 @@ set i [\fBinterp create\fR] } .CE .SH "SEE ALSO" -bgerror(n), load(n), safe(n), Tcl_CreateSlave(3), Tcl_Eval(3), Tcl_BackgroundException(3) +bgerror(n), load(n), safe(n), Tcl_CreateChild(3), Tcl_Eval(3), Tcl_BackgroundException(3) .SH KEYWORDS -alias, master interpreter, safe interpreter, slave interpreter +alias, parent interpreter, safe interpreter, child interpreter '\"Local Variables: '\"mode: nroff '\"End: diff --git a/doc/library.n b/doc/library.n index 4dcd598..8aa8af7 100644 --- a/doc/library.n +++ b/doc/library.n @@ -124,7 +124,7 @@ will read all the \fB.tcl\fR files in subdirectory \fBfoo\fR and generate a new index file \fBfoo/tclIndex\fR. .PP \fBAuto_mkindex\fR parses the Tcl scripts by sourcing them into a -slave interpreter and monitoring the proc and namespace commands that +child interpreter and monitoring the proc and namespace commands that are executed. Extensions can use the (undocumented) auto_mkindex_parser package to register other commands that can contribute to the auto_load index. You will have to read through diff --git a/doc/pkgMkIndex.n b/doc/pkgMkIndex.n index ec39be9..5a6b905 100644 --- a/doc/pkgMkIndex.n +++ b/doc/pkgMkIndex.n @@ -42,7 +42,7 @@ The default pattern is \fB*.tcl\fR and \fB*.[info sharedlibextension]\fR. \fBPkg_mkIndex\fR will create a file \fBpkgIndex.tcl\fR in \fIdir\fR with package information about all the files given by the \fIpattern\fR arguments. -It does this by loading each file into a slave +It does this by loading each file into a child interpreter and seeing what packages and new commands appear (this is why it is essential to have \fBpackage provide\fR commands or \fBTcl_PkgProvide\fR calls @@ -109,7 +109,7 @@ the use of \fIauto_reset\fR, and therefore its use is discouraged. .TP 15 \fB\-load \fIpkgPat\fR The index process will pre-load any packages that exist in the -current interpreter and match \fIpkgPat\fR into the slave interpreter used to +current interpreter and match \fIpkgPat\fR into the child interpreter used to generate the index. The pattern match uses string match rules, but without making case distinctions. See \fBCOMPLEX CASES\fR below. @@ -11,17 +11,17 @@ .SH NAME safe \- Creating and manipulating safe interpreters .SH SYNOPSIS -\fB::safe::interpCreate\fR ?\fIslave\fR? ?\fIoptions...\fR? +\fB::safe::interpCreate\fR ?\fIchild\fR? ?\fIoptions...\fR? .sp -\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR? +\fB::safe::interpInit\fR \fIchild\fR ?\fIoptions...\fR? .sp -\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR? +\fB::safe::interpConfigure\fR \fIchild\fR ?\fIoptions...\fR? .sp -\fB::safe::interpDelete\fR \fIslave\fR +\fB::safe::interpDelete\fR \fIchild\fR .sp -\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR +\fB::safe::interpAddToAccessPath\fR \fIchild\fR \fIdirectory\fR .sp -\fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR +\fB::safe::interpFindInAccessPath\fR \fIchild\fR \fIdirectory\fR .sp \fB::safe::setLogCmd\fR ?\fIcmd arg...\fR? .SS OPTIONS @@ -44,7 +44,7 @@ application or computer. Untrusted scripts are also prevented from disclosing information stored on the hosting computer or in the hosting application to any party. .PP -Safe Tcl allows a master interpreter to create safe, restricted +Safe Tcl allows a parent interpreter to create safe, restricted interpreters that contain a set of predefined aliases for the \fBsource\fR, \fBload\fR, \fBfile\fR, \fBencoding\fR, and \fBexit\fR commands and are able to use the auto-loading and package mechanisms. @@ -53,39 +53,47 @@ No knowledge of the file system structure is leaked to the safe interpreter, because it has access only to a virtualized path containing tokens. When the safe interpreter requests to source a file, it uses the token in the virtual path as part of the file name to source; the -master interpreter transparently +parent interpreter transparently translates the token into a real directory name and executes the requested operation (see the section \fBSECURITY\fR below for details). Different levels of security can be selected by using the optional flags of the commands described below. .PP -All commands provided in the master interpreter by Safe Tcl reside in +All commands provided in the parent interpreter by Safe Tcl reside in the \fBsafe\fR namespace. .SH COMMANDS -The following commands are provided in the master interpreter: +The following commands are provided in the parent interpreter: .TP -\fB::safe::interpCreate\fR ?\fIslave\fR? ?\fIoptions...\fR? +\fB::safe::interpCreate\fR ?\fIchild\fR? ?\fIoptions...\fR? Creates a safe interpreter, installs the aliases described in the section \fBALIASES\fR and initializes the auto-loading and package mechanism as specified by the supplied \fIoptions\fR. See the \fBOPTIONS\fR section below for a description of the optional arguments. -If the \fIslave\fR argument is omitted, a name will be generated. +If the \fIchild\fR argument is omitted, a name will be generated. \fB::safe::interpCreate\fR always returns the interpreter name. +.sp +The interpreter name \fIchild\fR may include namespace separators, +but may not have leading or trailing namespace separators, or excess +colon characters in namespace separators. The interpreter name is +qualified relative to the global namespace ::, not the namespace in which +the \fB::safe::interpCreate\fR command is evaluated. .TP -\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR? +\fB::safe::interpInit\fR \fIchild\fR ?\fIoptions...\fR? This command is similar to \fBinterpCreate\fR except it that does not -create the safe interpreter. \fIslave\fR must have been created by some -other means, like \fBinterp create\fR \fB\-safe\fR. +create the safe interpreter. \fIchild\fR must have been created by some +other means, like \fBinterp create\fR \fB\-safe\fR. The interpreter +name \fIchild\fR may include namespace separators, subject to the same +restrictions as for \fBinterpCreate\fR. .TP -\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR? +\fB::safe::interpConfigure\fR \fIchild\fR ?\fIoptions...\fR? If no \fIoptions\fR are given, returns the settings for all options for the named safe interpreter as a list of options and their current values -for that \fIslave\fR. +for that \fIchild\fR. If a single additional argument is provided, it will return a list of 2 elements \fIname\fR and \fIvalue\fR where \fIname\fR is the full name of that option and \fIvalue\fR the current value -for that option and the \fIslave\fR. +for that option and the \fIchild\fR. If more than two additional arguments are provided, it will reconfigure the safe interpreter and change each and only the provided options. See the section on \fBOPTIONS\fR below for options description. @@ -105,14 +113,14 @@ safe::interpConfigure $i0 \-delete {foo bar} \-statics 0 .CE .RE .TP -\fB::safe::interpDelete\fR \fIslave\fR +\fB::safe::interpDelete\fR \fIchild\fR Deletes the safe interpreter and cleans up the corresponding -master interpreter data structures. +parent interpreter data structures. If a \fIdeleteHook\fR script was specified for this interpreter it is evaluated before the interpreter is deleted, with the name of the interpreter as an additional argument. .TP -\fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR +\fB::safe::interpFindInAccessPath\fR \fIchild\fR \fIdirectory\fR This command finds and returns the token for the real directory \fIdirectory\fR in the safe interpreter's current virtual access path. It generates an error if the directory is not found. @@ -120,14 +128,14 @@ Example of use: .RS .PP .CS -$slave eval [list set tk_library \e +$child eval [list set tk_library \e [::safe::interpFindInAccessPath $name $tk_library]] .CE .RE .TP -\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR +\fB::safe::interpAddToAccessPath\fR \fIchild\fR \fIdirectory\fR This command adds \fIdirectory\fR to the virtual path maintained for the -safe interpreter in the master, and returns the token that can be used in +safe interpreter in the parent, and returns the token that can be used in the safe interpreter to obtain access to files in that directory. If the directory is already in the virtual path, it only returns the token without adding the directory to the virtual path again. @@ -135,7 +143,7 @@ Example of use: .RS .PP .CS -$slave eval [list set tk_library \e +$child eval [list set tk_library \e [::safe::interpAddToAccessPath $name $tk_library]] .CE .RE @@ -168,10 +176,10 @@ Note that the safe interpreter only received an error message saying that the file was not found: .PP .CS -NOTICE for slave interp10 : Created -NOTICE for slave interp10 : Setting accessPath=(/foo/bar) staticsok=1 nestedok=0 deletehook=() -NOTICE for slave interp10 : auto_path in interp10 has been set to {$p(:0:)} -ERROR for slave interp10 : /foo/bar/init.tcl: no such file or directory +NOTICE for child interp10 : Created +NOTICE for child interp10 : Setting accessPath=(/foo/bar) staticsok=1 nestedok=0 deletehook=() +NOTICE for child interp10 : auto_path in interp10 has been set to {$p(:0:)} +ERROR for child interp10 : /foo/bar/init.tcl: no such file or directory .CE .RE .SS OPTIONS @@ -187,7 +195,7 @@ This option sets the list of directories from which the safe interpreter can \fBsource\fR and \fBload\fR files. If this option is not specified, or if it is given as the empty list, the safe interpreter will use the same directories as its -master for auto-loading. +parent for auto-loading. See the section \fBSECURITY\fR below for more detail about virtual paths, tokens and access control. .TP @@ -216,7 +224,7 @@ to load packages into its own sub-interpreters. .TP \fB\-deleteHook\fR \fIscript\fR When this option is given a non-empty \fIscript\fR, it will be -evaluated in the master with the name of +evaluated in the parent with the name of the safe interpreter as an additional argument just before actually deleting the safe interpreter. Giving an empty value removes any currently installed deletion hook @@ -281,8 +289,8 @@ potential for information leakage about its directory structure. To prevent this, commands that take file names as arguments in a safe interpreter use tokens instead of the real directory names. These tokens are translated to the real directory name while a request to, -e.g., source a file is mediated by the master interpreter. -This virtual path system is maintained in the master interpreter for each safe +e.g., source a file is mediated by the parent interpreter. +This virtual path system is maintained in the parent interpreter for each safe interpreter created by \fB::safe::interpCreate\fR or initialized by \fB::safe::interpInit\fR and the path maps tokens accessible in the safe interpreter into real path @@ -291,7 +299,7 @@ from gaining knowledge about the structure of the file system of the host on which the interpreter is executing. The only valid file names arguments -for the \fBsource\fR and \fBload\fR aliases provided to the slave +for the \fBsource\fR and \fBload\fR aliases provided to the child are path in the form of \fB[file join \fItoken filename\fB]\fR (i.e. when using the native file path formats: \fItoken\fB/\fIfilename\fR @@ -320,26 +328,26 @@ or be called .PP Each element of the initial access path list will be assigned a token that will be set in -the slave \fBauto_path\fR and the first element of that list will be set as -the \fBtcl_library\fR for that slave. +the child \fBauto_path\fR and the first element of that list will be set as +the \fBtcl_library\fR for that child. .PP If the access path argument is not given or is the empty list, -the default behavior is to let the slave access the same packages -as the master has access to (Or to be more precise: +the default behavior is to let the child access the same packages +as the parent has access to (Or to be more precise: only packages written in Tcl (which by definition cannot be dangerous -as they run in the slave interpreter) and C extensions that -provides a _SafeInit entry point). For that purpose, the master's -\fBauto_path\fR will be used to construct the slave access path. -In order that the slave successfully loads the Tcl library files +as they run in the child interpreter) and C extensions that +provides a _SafeInit entry point). For that purpose, the parent's +\fBauto_path\fR will be used to construct the child access path. +In order that the child successfully loads the Tcl library files (which includes the auto-loading mechanism itself) the \fBtcl_library\fR will be added or moved to the first position if necessary, in the -slave access path, so the slave -\fBtcl_library\fR will be the same as the master's (its real -path will still be invisible to the slave though). -In order that auto-loading works the same for the slave and -the master in this by default case, the first-level -sub directories of each directory in the master \fBauto_path\fR will -also be added (if not already included) to the slave access path. +child access path, so the child +\fBtcl_library\fR will be the same as the parent's (its real +path will still be invisible to the child though). +In order that auto-loading works the same for the child and +the parent in this by default case, the first-level +sub directories of each directory in the parent \fBauto_path\fR will +also be added (if not already included) to the child access path. You can always specify a more restrictive path for which sub directories will never be searched by explicitly specifying your directory list with the \fB\-accessPath\fR flag @@ -352,8 +360,8 @@ to synchronize its \fBauto_index\fR with the new token list. .SH "SEE ALSO" interp(n), library(n), load(n), package(n), source(n), unknown(n) .SH KEYWORDS -alias, auto\-loading, auto_mkindex, load, master interpreter, safe -interpreter, slave interpreter, source +alias, auto\-loading, auto_mkindex, load, parent interpreter, safe +interpreter, child interpreter, source '\" Local Variables: '\" mode: nroff '\" End: diff --git a/doc/source.n b/doc/source.n index 353b8fb..8757cb8 100644 --- a/doc/source.n +++ b/doc/source.n @@ -47,7 +47,7 @@ A leading BOM (Byte order mark) contained in the file is ignored for unicode enc .PP The \fB\-encoding\fR option is used to specify the encoding of the data stored in \fIfileName\fR. When the \fB\-encoding\fR option -is omitted, the system encoding is assumed. +is omitted, the utf-8 encoding is assumed. .SH EXAMPLE .PP Run the script in the file \fBfoo.tcl\fR and then the script in the diff --git a/doc/tcltest.n b/doc/tcltest.n index b161a2b..25e5e5e 100644 --- a/doc/tcltest.n +++ b/doc/tcltest.n @@ -203,7 +203,7 @@ array. Returns an empty string. .TP \fBrunAllTests\fR . -This is a master command meant to run an entire suite of tests, +This is a main command meant to run an entire suite of tests, spanning multiple files and/or directories, as governed by the configurable options of \fBtcltest\fR. See \fBRUNNING ALL TESTS\fR below for a complete description of the many variations possible @@ -804,17 +804,17 @@ then a copy of \fBinterpreter\fR will be \fBexec\fR'd to evaluate each file. The multi-process operation is useful when testing can cause errors so severe that a process terminates. Although such an error may terminate a child -process evaluating one file, the master process can continue +process evaluating one file, the main process can continue with the rest of the test suite. In multi-process operation, -the configuration of \fBtcltest\fR in the master process is +the configuration of \fBtcltest\fR in the main process is passed to the child processes as command line arguments, with the exception of \fBconfigure \-outfile\fR. The \fBrunAllTests\fR command in the -master process collects all output from the child processes -and collates their results into one master report. Any +main process collects all output from the child processes +and collates their results into one main report. Any reports of individual test failures, or messages requested by a \fBconfigure \-verbose\fR setting are passed directly -on to \fBoutputChannel\fR by the master process. +on to \fBoutputChannel\fR by the main process. .PP After evaluating all selected test files, a summary of the results is printed to \fBoutputChannel\fR. The summary @@ -1134,7 +1134,7 @@ A good namespace to use is a child namespace \fBtest\fR of the namespace of the module you are testing. .PP A test file should also be able to be evaluated directly as a script, -not depending on being called by a master \fBrunAllTests\fR. This +not depending on being called by a main \fBrunAllTests\fR. This means that each test file should process command line arguments to give the tester all the configuration control that \fBtcltest\fR provides. .PP @@ -1145,7 +1145,7 @@ Here is a sketch of a sample test file illustrating those points: .RS .PP .CS -package require tcltest 2.2 +package require tcltest 2.5 eval \fB::tcltest::configure\fR $argv package require example namespace eval ::example::test { @@ -1175,12 +1175,12 @@ doing any necessary setup. This script is usually named \fBall.tcl\fR because that is the default name used by \fBrunAllTests\fR when combining multiple test suites into one testing run. .IP [8] -Here is a sketch of a sample test suite master script: +Here is a sketch of a sample test suite main script: .RS .PP .CS -package require Tcl 8.4 -package require tcltest 2.2 +package require Tcl 8.6 +package require tcltest 2.5 package require example \fB::tcltest::configure\fR -testdir \e [file dirname [file normalize [info script]]] diff --git a/generic/regcomp.c b/generic/regcomp.c index 99dfef1..3be5172 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -56,7 +56,7 @@ static const chr *scanplain(struct vars *); static void onechr(struct vars *, pchr, struct state *, struct state *); static void dovec(struct vars *, struct cvec *, struct state *, struct state *); static void wordchrs(struct vars *); -static struct subre *subre(struct vars *, int, int, struct state *, struct state *); +static struct subre *sub_re(struct vars *, int, int, struct state *, struct state *); static void freesubre(struct vars *, struct subre *); static void freesrnode(struct vars *, struct subre *); static int numst(struct subre *, int); @@ -663,7 +663,7 @@ parse( assert(stopper == ')' || stopper == EOS); - branches = subre(v, '|', LONGER, init, final); + branches = sub_re(v, '|', LONGER, init, final); NOERRN(); branch = branches; firstbranch = 1; @@ -673,7 +673,7 @@ parse( * Need a place to hang the branch. */ - branch->right = subre(v, '|', LONGER, init, final); + branch->right = sub_re(v, '|', LONGER, init, final); NOERRN(); branch = branch->right; } @@ -744,7 +744,7 @@ parsebranch( lp = left; seencontent = 0; - t = subre(v, '=', 0, left, right); /* op '=' is tentative */ + t = sub_re(v, '=', 0, left, right); /* op '=' is tentative */ NOERRN(); while (!SEE('|') && !SEE(stopper) && !SEE(EOS)) { if (seencontent) { /* implicit concat operator */ @@ -977,7 +977,7 @@ parseqatom( NOERR(); if (cap) { v->subs[subno] = atom; - t = subre(v, '(', atom->flags|CAP, lp, rp); + t = sub_re(v, '(', atom->flags|CAP, lp, rp); NOERR(); t->subno = subno; t->left = atom; @@ -995,7 +995,7 @@ parseqatom( INSIST(v->subs[v->nextvalue] != NULL, REG_ESUBREG); NOERR(); assert(v->nextvalue > 0); - atom = subre(v, 'b', BACKR, lp, rp); + atom = sub_re(v, 'b', BACKR, lp, rp); NOERR(); subno = v->nextvalue; atom->subno = subno; @@ -1110,7 +1110,7 @@ parseqatom( */ if (atom == NULL) { - atom = subre(v, '=', 0, lp, rp); + atom = sub_re(v, '=', 0, lp, rp); NOERR(); } @@ -1147,7 +1147,7 @@ parseqatom( * Break remaining subRE into x{...} and what follows. */ - t = subre(v, '.', COMBINE(qprefer, atom->flags), lp, rp); + t = sub_re(v, '.', COMBINE(qprefer, atom->flags), lp, rp); NOERR(); t->left = atom; atomp = &t->left; @@ -1161,7 +1161,7 @@ parseqatom( */ assert(top->op == '=' && top->left == NULL && top->right == NULL); - top->left = subre(v, '=', top->flags, top->begin, lp); + top->left = sub_re(v, '=', top->flags, top->begin, lp); NOERR(); top->op = '.'; top->right = t; @@ -1230,9 +1230,9 @@ parseqatom( assert(m >= 1 && m != DUPINF && n >= 1); repeat(v, s, atom->begin, m-1, (n == DUPINF) ? n : n-1); f = COMBINE(qprefer, atom->flags); - t = subre(v, '.', f, s, atom->end); /* prefix and atom */ + t = sub_re(v, '.', f, s, atom->end); /* prefix and atom */ NOERR(); - t->left = subre(v, '=', PREF(f), s, atom->begin); + t->left = sub_re(v, '=', PREF(f), s, atom->begin); NOERR(); t->right = atom; *atomp = t; @@ -1247,7 +1247,7 @@ parseqatom( dupnfa(v->nfa, atom->begin, atom->end, s, s2); repeat(v, s, s2, m, n); f = COMBINE(qprefer, atom->flags); - t = subre(v, '*', f, s, s2); + t = sub_re(v, '*', f, s, s2); NOERR(); t->min = (short) m; t->max = (short) n; @@ -1265,7 +1265,7 @@ parseqatom( t->right = parsebranch(v, stopper, type, s2, rp, 1); } else { EMPTYARC(s2, rp); - t->right = subre(v, '=', 0, s2, rp); + t->right = sub_re(v, '=', 0, s2, rp); } NOERR(); assert(SEE('|') || SEE(stopper) || SEE(EOS)); @@ -1717,12 +1717,12 @@ wordchrs( } /* - - subre - allocate a subre - ^ static struct subre *subre(struct vars *, int, int, struct state *, + - sub_re - allocate a subre + ^ static struct subre *sub_re(struct vars *, int, int, struct state *, ^ struct state *); */ static struct subre * -subre( +sub_re( struct vars *v, int op, int flags, diff --git a/generic/regexec.c b/generic/regexec.c index b5f161b..e7260cd 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -73,7 +73,7 @@ struct dfa { chr *lastnopr; /* location of last cache-flushed NOPROGRESS */ struct sset *search; /* replacement-search-pointer memory */ int cptsmalloced; /* were the areas individually malloced? */ - char *mallocarea; /* self, or master malloced area, or NULL */ + char *mallocarea; /* self, or malloced area, or NULL */ }; #define WORK 1 /* number of work bitvectors needed */ diff --git a/generic/tcl.decls b/generic/tcl.decls index c05da7e..e49ed66 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -316,12 +316,12 @@ declare 85 { int flags) } declare 86 { - int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd, + int Tcl_CreateAlias(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv) } declare 87 { - int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd, + int Tcl_CreateAliasObj(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]) } @@ -364,7 +364,7 @@ declare 96 { Tcl_CmdDeleteProc *deleteProc) } declare 97 { - Tcl_Interp *Tcl_CreateSlave(Tcl_Interp *interp, const char *slaveName, + Tcl_Interp *Tcl_CreateChild(Tcl_Interp *interp, const char *name, int isSafe) } declare 98 { @@ -527,12 +527,12 @@ declare 147 {deprecated {see TIP #559. Use Tcl_ResetResult}} { void Tcl_FreeResult(Tcl_Interp *interp) } declare 148 { - int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, + int Tcl_GetAlias(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr) } declare 149 { - int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd, + int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv) } @@ -582,10 +582,10 @@ declare 162 { const char *Tcl_GetHostName(void) } declare 163 { - int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *slaveInterp) + int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *childInterp) } declare 164 { - Tcl_Interp *Tcl_GetMaster(Tcl_Interp *interp) + Tcl_Interp *Tcl_GetParent(Tcl_Interp *interp) } declare 165 { const char *Tcl_GetNameOfExecutable(void) @@ -616,7 +616,7 @@ declare 171 { int Tcl_GetServiceMode(void) } declare 172 { - Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName) + Tcl_Interp *Tcl_GetChild(Tcl_Interp *interp, const char *name) } declare 173 { Tcl_Channel Tcl_GetStdChannel(int type) diff --git a/generic/tcl.h b/generic/tcl.h index 02ef01e..5de113d 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -361,7 +361,7 @@ typedef long LONG; */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) -# if defined(_MSC_VER) || defined(_WIN32) +# if defined(_WIN32) && (!defined(__USE_MINGW_ANSI_STDIO) || !__USE_MINGW_ANSI_STDIO) # define TCL_WIDE_INT_TYPE __int64 # define TCL_LL_MODIFIER "I64" # if defined(_WIN64) @@ -973,11 +973,14 @@ typedef struct Tcl_DString { #define TCL_DONT_QUOTE_HASH 8 /* - * Flag that may be passed to Tcl_GetIndexFromObj to force it to disallow - * abbreviated strings. + * Flags that may be passed to Tcl_GetIndexFromObj. + * TCL_EXACT disallows abbreviated strings. + * TCL_INDEX_TEMP_TABLE disallows caching of lookups. A possible use case is + * a table that will not live long enough to make it worthwhile. */ -#define TCL_EXACT 1 +#define TCL_EXACT 1 +#define TCL_INDEX_TEMP_TABLE 2 /* *---------------------------------------------------------------------------- @@ -2476,7 +2479,7 @@ EXTERN int TclZipfs_AppHook(int *argc, char ***argv); # define Tcl_DecrRefCount(objPtr) \ do { \ Tcl_Obj *_objPtr = (objPtr); \ - if ((_objPtr)->refCount-- <= 1) { \ + if (_objPtr->refCount-- <= 1) { \ TclFreeObj(_objPtr); \ } \ } while(0) diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index bc4716d..4a84255 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -24,7 +24,7 @@ #include "tclInt.h" #if !TCL_THREADS || !defined(USE_THREAD_ALLOC) -#if USE_TCLALLOC +#if defined(USE_TCLALLOC) && USE_TCLALLOC /* * We should really make use of AC_CHECK_TYPE(caddr_t) here, but it can wait diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 9e5e947..605758b 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -131,7 +131,7 @@ enum BasicBlockFlags { * Source instruction type recognized by the assembler. */ -typedef enum TalInstType { +typedef enum { ASSEM_1BYTE, /* Fixed arity, 1-byte instruction */ ASSEM_BEGIN_CATCH, /* Begin catch: one 4-byte jump offset to be * converted to appropriate exception @@ -145,8 +145,6 @@ typedef enum TalInstType { * 1 */ ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1 * operands, produces 1, N > 0 */ - ASSEM_DICT_GET_DEF, /* 'dict getwithdefault' - consumes N+2 - * operands, produces 1, N > 0 */ ASSEM_DICT_SET, /* specifies key count and LVT index, consumes * N+1 operands, produces 1, N > 0 */ ASSEM_DICT_UNSET, /* specifies key count and LVT index, consumes @@ -189,8 +187,10 @@ typedef enum TalInstType { * produces N */ ASSEM_SINT1, /* One 1-byte signed-integer operand * (INCR_STK_IMM) */ - ASSEM_SINT4_LVT4 /* Signed 4-byte integer operand followed by + ASSEM_SINT4_LVT4, /* Signed 4-byte integer operand followed by * LVT entry. Fixed arity */ + ASSEM_DICT_GET_DEF /* 'dict getwithdefault' - consumes N+2 + * operands, produces 1, N > 0 */ } TalInstType; /* @@ -815,7 +815,7 @@ TclNRAssembleObjCmd( Tcl_AddErrorInfo(interp, "\n (\""); Tcl_AppendObjToErrorInfo(interp, objv[0]); Tcl_AddErrorInfo(interp, "\" body, line "); - backtrace = Tcl_NewWideIntObj(Tcl_GetErrorLine(interp)); + TclNewIntObj(backtrace, Tcl_GetErrorLine(interp)); Tcl_AppendObjToErrorInfo(interp, backtrace); Tcl_AddErrorInfo(interp, ")"); return TCL_ERROR; @@ -1266,7 +1266,7 @@ AssembleOneLine( Tcl_Obj* instNameObj; /* Name of the instruction */ int tblIdx; /* Index in TalInstructionTable of the * instruction */ - enum TalInstType instType; /* Type of the instruction */ + TalInstType instType; /* Type of the instruction */ Tcl_Obj* operand1Obj = NULL; /* First operand to the instruction */ const char* operand1; /* String rep of the operand */ @@ -2098,8 +2098,9 @@ GetNextOperand( * with \-substitutions done. */ { Tcl_Interp* interp = (Tcl_Interp*) assemEnvPtr->envPtr->iPtr; - Tcl_Obj* operandObj = Tcl_NewObj(); + Tcl_Obj* operandObj; + TclNewObj(operandObj); if (!TclWordKnownAtCompileTime(*tokenPtrPtr, operandObj)) { Tcl_DecrRefCount(operandObj); if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { @@ -4269,7 +4270,7 @@ AddBasicBlockRangeToErrorInfo( Tcl_Obj* lineNo; /* Line number in the source */ Tcl_AddErrorInfo(interp, "\n in assembly code between lines "); - lineNo = Tcl_NewWideIntObj(bbPtr->startLine); + TclNewIntObj(lineNo, bbPtr->startLine); Tcl_IncrRefCount(lineNo); Tcl_AppendObjToErrorInfo(interp, lineNo); Tcl_AddErrorInfo(interp, " and "); diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 2b1bae9..4e2bcb1 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -684,7 +684,7 @@ Tcl_CreateInterp(void) TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble"); TclRegisterCommandTypeName(TclAliasObjCmd, "alias"); TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias"); - TclRegisterCommandTypeName(TclSlaveObjCmd, "interp"); + TclRegisterCommandTypeName(TclChildObjCmd, "interp"); TclRegisterCommandTypeName(TclInvokeImportedCmd, "import"); TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object"); TclRegisterCommandTypeName(TclOOPrivateObjectCmd, "privateObject"); @@ -708,7 +708,7 @@ Tcl_CreateInterp(void) #endif iPtr->freeProc = NULL; iPtr->errorLine = 0; - iPtr->objResultPtr = Tcl_NewObj(); + TclNewObj(iPtr->objResultPtr); Tcl_IncrRefCount(iPtr->objResultPtr); iPtr->handle = TclHandleCreate(iPtr); iPtr->globalNsPtr = NULL; @@ -796,8 +796,7 @@ Tcl_CreateInterp(void) iPtr->activeInterpTracePtr = NULL; iPtr->assocData = NULL; iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */ - iPtr->emptyObjPtr = Tcl_NewObj(); - /* Another empty object. */ + TclNewObj(iPtr->emptyObjPtr); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); #ifndef TCL_NO_DEPRECATED iPtr->resultSpace[0] = 0; @@ -863,7 +862,7 @@ Tcl_CreateInterp(void) * TIP #285, Script cancellation support. */ - iPtr->asyncCancelMsg = Tcl_NewObj(); + TclNewObj(iPtr->asyncCancelMsg); cancelInfo = (CancelInfo *)ckalloc(sizeof(CancelInfo)); cancelInfo->interp = interp; @@ -2785,6 +2784,8 @@ TclCreateObjCommandInNs( Command *refCmdPtr = oldRefPtr->importedCmdPtr; dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; + cmdPtr->refCount++; + TclCleanupCommandMacro(dataPtr->realCmdPtr); dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; } @@ -2988,7 +2989,7 @@ TclRenameCommand( } cmdNsPtr = cmdPtr->nsPtr; - oldFullName = Tcl_NewObj(); + TclNewObj(oldFullName); Tcl_IncrRefCount(oldFullName); Tcl_GetCommandFullName(interp, cmd, oldFullName); @@ -3374,7 +3375,7 @@ Tcl_GetCommandFullName( * separator, and the command name. */ - if (cmdPtr != NULL) { + if ((cmdPtr != NULL) && TclRoutineHasName(cmdPtr)) { if (cmdPtr->nsPtr != NULL) { Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1); if (cmdPtr->nsPtr != iPtr->globalNsPtr) { @@ -3464,7 +3465,7 @@ Tcl_DeleteCommandFromToken( * and skip nested deletes. */ - if (cmdPtr->flags & CMD_IS_DELETED) { + if (cmdPtr->flags & CMD_DYING) { /* * Another deletion is already in progress. Remove the hash table * entry now, but don't invoke a callback or free the command @@ -3496,7 +3497,7 @@ Tcl_DeleteCommandFromToken( * be ignored. */ - cmdPtr->flags |= CMD_IS_DELETED; + cmdPtr->flags |= CMD_DYING; /* * Call trace functions for the command being deleted. Then delete its @@ -3526,7 +3527,7 @@ Tcl_DeleteCommandFromToken( } /* - * The list of command exported from the namespace might have changed. + * The list of commands exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we need * the info will be soon enough. */ @@ -3661,7 +3662,7 @@ CallCommandTraces( * While a rename trace is active, we will not process any more rename * traces; while a delete trace is active we will never reach here - * because Tcl_DeleteCommandFromToken checks for the condition - * (cmdPtr->flags & CMD_IS_DELETED) and returns immediately when a + * (cmdPtr->flags & CMD_DYING) and returns immediately when a * command deletion is in progress. For all other traces, delete * traces will not be invoked but a call to TraceCommandProc will * ensure that tracePtr->clientData is freed whenever the command @@ -3792,7 +3793,7 @@ CancelEvalProc( TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED); /* - * Now, we must set the script cancellation flags on all the slave + * Now, we must set the script cancellation flags on all the child * interpreters belonging to this one. */ @@ -4041,7 +4042,7 @@ OldMathFuncProc( if (funcResult.type == TCL_INT) { TclNewIntObj(valuePtr, funcResult.intValue); } else if (funcResult.type == TCL_WIDE_INT) { - valuePtr = Tcl_NewWideIntObj(funcResult.wideValue); + TclNewIntObj(valuePtr, funcResult.wideValue); } else { return CheckDoubleResult(interp, funcResult.doubleValue); } @@ -4200,7 +4201,7 @@ Tcl_ListMathFuncs( if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) { result = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); } else { - result = Tcl_NewObj(); + TclNewObj(result); } Tcl_DecrRefCount(script); Tcl_RestoreInterpState(interp, state); @@ -4321,7 +4322,7 @@ TclResetCancellation( * Tcl_Canceled -- * * Check if the script in progress has been canceled, i.e., - * Tcl_CancelEval was called for this interpreter or any of its master + * Tcl_CancelEval was called for this interpreter or any of its parent * interpreters. * * Results: @@ -5214,7 +5215,7 @@ TEOV_RunLeaveTraces( int length; const char *command = TclGetStringFromObj(commandPtr, &length); - if (!(cmdPtr->flags & CMD_IS_DELETED)) { + if (!(cmdPtr->flags & CMD_DYING)) { if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) { traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); @@ -5407,7 +5408,7 @@ TclEvalEx( * the embedded command, which is refered to * by 'script'. The 'clNextOuter' refers to * the current entry in the table of - * continuation lines in this "master script", + * continuation lines in this "main script", * and the character offsets are relative to * the 'outerScript' as well. * @@ -6460,7 +6461,7 @@ TclNREvalObjEx( /* * Shimmer protection! Always pass an unshared obj. The caller could * incr the refCount of objPtr AFTER calling us! To be completely safe - * we always make a copy. The callback takes care od the refCounts for + * we always make a copy. The callback takes care of the refCounts for * both listPtr and objPtr. * * TODO: Create a test to demo this need, or eliminate it. @@ -7029,7 +7030,7 @@ TclObjInvoke( int TclNRInvoke( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -7511,7 +7512,7 @@ Tcl_GetVersion( static int ExprCeilFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -7551,7 +7552,7 @@ ExprCeilFunc( static int ExprFloorFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -7591,7 +7592,7 @@ ExprFloorFunc( static int ExprIsqrtFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter list. */ @@ -7697,7 +7698,7 @@ ExprIsqrtFunc( static int ExprSqrtFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -7865,7 +7866,7 @@ ExprBinaryFunc( static int ExprAbsFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -7964,7 +7965,7 @@ ExprAbsFunc( static int ExprBoolFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -7985,7 +7986,7 @@ ExprBoolFunc( static int ExprDoubleFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -8012,7 +8013,7 @@ ExprDoubleFunc( static int ExprIntFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -8068,7 +8069,7 @@ ExprIntFunc( static int ExprWideFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -8089,7 +8090,7 @@ ExprWideFunc( */ static int ExprMaxMinFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -8129,7 +8130,7 @@ ExprMaxMinFunc( static int ExprMaxFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -8140,7 +8141,7 @@ ExprMaxFunc( static int ExprMinFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -8151,7 +8152,7 @@ ExprMinFunc( static int ExprRandFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -8244,7 +8245,7 @@ ExprRandFunc( static int ExprRoundFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -8323,7 +8324,7 @@ ExprRoundFunc( static int ExprSrandFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ @@ -8512,7 +8513,7 @@ ClassifyDouble( static int ExprIsFiniteFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count */ @@ -8543,7 +8544,7 @@ ExprIsFiniteFunc( static int ExprIsInfinityFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count */ @@ -8573,7 +8574,7 @@ ExprIsInfinityFunc( static int ExprIsNaNFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count */ @@ -8603,7 +8604,7 @@ ExprIsNaNFunc( static int ExprIsNormalFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count */ @@ -8633,7 +8634,7 @@ ExprIsNormalFunc( static int ExprIsSubnormalFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count */ @@ -8663,7 +8664,7 @@ ExprIsSubnormalFunc( static int ExprIsUnorderedFunc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count */ @@ -8704,7 +8705,7 @@ ExprIsUnorderedFunc( static int FloatClassifyObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count */ @@ -8813,7 +8814,7 @@ MathFuncWrongNumArgs( static int DTraceObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), TCL_UNUSED(Tcl_Interp *), int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -9197,7 +9198,7 @@ TclSetTailcall( int TclNRTailcallObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -9390,7 +9391,7 @@ TclNRYieldObjCmd( int TclNRYieldToObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -9513,7 +9514,7 @@ NRCoroutineCallerCallback( SAVE_CONTEXT(corPtr->running); RESTORE_CONTEXT(corPtr->caller); - if (cmdPtr->flags & CMD_IS_DELETED) { + if (cmdPtr->flags & CMD_DYING) { /* * The command was deleted while it was running: wind down the * execEnv, this will do the complete cleanup. RewindCoroutine will @@ -9700,7 +9701,7 @@ TclNREvalList( static int CoroTypeObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -9790,7 +9791,7 @@ GetCoroutineFromObj( static int TclNRCoroInjectObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -9835,7 +9836,7 @@ TclNRCoroInjectObjCmd( static int TclNRCoroProbeObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -9959,7 +9960,7 @@ InjectHandler( * I don't think this is reachable... */ - Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewIntObj(nargs)); + Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewWideIntObj(nargs)); } Tcl_ListObjAppendElement(NULL, listPtr, Tcl_GetObjResult(interp)); } @@ -10028,7 +10029,7 @@ InjectHandlerPostCall( static int NRInjectObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -10137,7 +10138,7 @@ TclNRInterpCoroutine( int TclNRCoroutineObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -10270,7 +10271,7 @@ TclNRCoroutineObjCmd( int TclInfoCoroutineCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -10282,7 +10283,7 @@ TclInfoCoroutineCmd( return TCL_ERROR; } - if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) { + if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) { Tcl_Obj *namePtr; TclNewObj(namePtr); diff --git a/generic/tclBinary.c b/generic/tclBinary.c index bb82fe7..f53c707 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -274,7 +274,7 @@ typedef struct ByteArray { * array. */ unsigned int allocated; /* The amount of space actually allocated * minus 1 byte. */ - unsigned char bytes[1]; /* The array of bytes. The actual size of this + unsigned char bytes[TCLFLEXARRAY]; /* The array of bytes. The actual size of this * field depends on the 'allocated' field * above. */ } ByteArray; @@ -1163,7 +1163,7 @@ BinaryFormatCmd( * bytes and filling with nulls. */ - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); buffer = Tcl_SetByteArrayLength(resultPtr, length); memset(buffer, 0, length); @@ -1595,7 +1595,7 @@ BinaryScanCmd( } } src = buffer + offset; - valuePtr = Tcl_NewObj(); + TclNewObj(valuePtr); Tcl_SetObjLength(valuePtr, count); dest = TclGetString(valuePtr); @@ -1650,7 +1650,7 @@ BinaryScanCmd( } } src = buffer + offset; - valuePtr = Tcl_NewObj(); + TclNewObj(valuePtr); Tcl_SetObjLength(valuePtr, count); dest = TclGetString(valuePtr); @@ -1734,7 +1734,7 @@ BinaryScanCmd( if ((length - offset) < (count * size)) { goto done; } - valuePtr = Tcl_NewObj(); + TclNewObj(valuePtr); src = buffer + offset; for (i = 0; i < count; i++) { elementPtr = ScanNumber(src, cmd, flags, &numberCachePtr); @@ -2376,8 +2376,9 @@ ScanNumber( return (Tcl_Obj *)Tcl_GetHashValue(hPtr); } if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) { - Tcl_Obj *objPtr = Tcl_NewWideIntObj(value); + Tcl_Obj *objPtr; + TclNewIntObj(objPtr, value); Tcl_IncrRefCount(objPtr); Tcl_SetHashValue(hPtr, objPtr); return objPtr; @@ -2761,7 +2762,7 @@ BinaryEncode64( maxlen = 0; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); data = Tcl_GetByteArrayFromObj(objv[objc - 1], &count); if (count > 0) { unsigned char *cursor = NULL; @@ -2913,7 +2914,7 @@ BinaryEncodeUu( * enough". */ - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); offset = 0; data = Tcl_GetByteArrayFromObj(objv[objc - 1], &count); rawLength = (lineLength - 1) * 3 / 4; diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index c1a585e..f761521 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -1288,7 +1288,7 @@ TclFinalizeMemorySubsystem(void) Tcl_MutexUnlock(ckallocMutexPtr); #endif -#if USE_TCLALLOC +#if defined(USE_TCLALLOC) && USE_TCLALLOC TclFinalizeAllocSubsystem(); #endif } diff --git a/generic/tclClock.c b/generic/tclClock.c index baaa568..ba85fec 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -263,7 +263,7 @@ TclClockInit( }; /* - * Safe interps get [::clock] as alias to a master, so do not need their + * Safe interps get [::clock] as alias to a parent, so do not need their * own copies of the support routines. */ diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 056bd47..7973154 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -59,7 +59,7 @@ static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, static const char * GetTypeFromMode(int mode); static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName, Tcl_StatBuf *statPtr); -static inline int EachloopCmd(Tcl_Interp *interp, int collect, +static int EachloopCmd(Tcl_Interp *interp, int collect, int objc, Tcl_Obj *const objv[]); static Tcl_NRPostProc CatchObjCmdCallback; static Tcl_NRPostProc ExprCallback; @@ -2599,7 +2599,7 @@ TclNRLmapCmd( return EachloopCmd(interp, TCL_EACH_COLLECT, objc, objv); } -static inline int +static int EachloopCmd( Tcl_Interp *interp, /* Our context for variables and script * evaluation. */ diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 60331f5..da8dc65 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -383,7 +383,7 @@ Tcl_IncrObjCmd( if (objc == 3) { incrPtr = objv[2]; } else { - incrPtr = Tcl_NewWideIntObj(1); + TclNewIntObj(incrPtr, 1); } Tcl_IncrRefCount(incrPtr); newValuePtr = TclIncrObjVar2(interp, objv[1], NULL, @@ -691,7 +691,7 @@ InfoCommandsCmd( if (entryPtr != NULL) { if (specificNsInPattern) { cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr); - elemObjPtr = Tcl_NewObj(); + TclNewObj(elemObjPtr); Tcl_GetCommandFullName(interp, cmd, elemObjPtr); } else { cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); @@ -742,7 +742,7 @@ InfoCommandsCmd( || Tcl_StringMatch(cmdName, simplePattern)) { if (specificNsInPattern) { cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr); - elemObjPtr = Tcl_NewObj(); + TclNewObj(elemObjPtr); Tcl_GetCommandFullName(interp, cmd, elemObjPtr); } else { elemObjPtr = Tcl_NewStringObj(cmdName, -1); @@ -969,8 +969,9 @@ InfoDefaultCmd( } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); } else { - Tcl_Obj *nullObjPtr = Tcl_NewObj(); + Tcl_Obj *nullObjPtr; + TclNewObj(nullObjPtr); valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, nullObjPtr, TCL_LEAVE_ERR_MSG); if (valueObjPtr == NULL) { @@ -1026,7 +1027,7 @@ InfoErrorStackCmd( target = interp; if (objc == 2) { - target = Tcl_GetSlave(interp, TclGetString(objv[1])); + target = Tcl_GetChild(interp, TclGetString(objv[1])); if (target == NULL) { return TCL_ERROR; } @@ -1885,7 +1886,7 @@ InfoProcsCmd( } else { simpleProcOK: if (specificNsInPattern) { - elemObjPtr = Tcl_NewObj(); + TclNewObj(elemObjPtr); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, elemObjPtr); } else { @@ -1906,15 +1907,15 @@ InfoProcsCmd( if (!TclIsProc(cmdPtr)) { realCmdPtr = (Command *) - TclGetOriginalCommand((Tcl_Command) cmdPtr); + TclGetOriginalCommand((Tcl_Command)cmdPtr); if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { goto procOK; } } else { procOK: if (specificNsInPattern) { - elemObjPtr = Tcl_NewObj(); - Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, + TclNewObj(elemObjPtr); + Tcl_GetCommandFullName(interp, (Tcl_Command)cmdPtr, elemObjPtr); } else { elemObjPtr = Tcl_NewStringObj(cmdName, -1); @@ -2142,7 +2143,7 @@ InfoCmdTypeCmd( } /* - * There's one special case: safe slave interpreters can't see aliases as + * There's one special case: safe interpreters can't see aliases as * aliases as they're part of the security mechanisms. */ @@ -2217,7 +2218,7 @@ Tcl_JoinObjCmd( } else { int i; - resObjPtr = Tcl_NewObj(); + TclNewObj(resObjPtr); for (i = 0; i < listLen; i++) { if (i > 0) { @@ -3156,7 +3157,7 @@ Tcl_LsearchObjCmd( "-real", "-regexp", "-sorted", "-start", "-stride", "-subindices", NULL }; - enum options { + enum lsearchoptions { LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_BISECT, LSEARCH_DECREASING, LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INDEX, LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE, @@ -3204,7 +3205,7 @@ Tcl_LsearchObjCmd( result = TCL_ERROR; goto done; } - switch ((enum options) index) { + switch ((enum lsearchoptions) index) { case LSEARCH_ALL: /* -all */ allMatches = 1; break; @@ -3513,7 +3514,8 @@ Tcl_LsearchObjCmd( if (allMatches || inlineReturn) { Tcl_ResetResult(interp); } else { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1)); + TclNewIntObj(itemPtr, TCL_INDEX_NONE); + Tcl_SetObjResult(interp, itemPtr); } goto done; } @@ -3802,10 +3804,11 @@ Tcl_LsearchObjCmd( } else if (returnSubindices) { int j; - itemPtr = Tcl_NewWideIntObj(i+groupOffset); + TclNewIntObj(itemPtr, i+groupOffset); for (j=0 ; j<sortInfo.indexc ; j++) { - Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewWideIntObj( - TclIndexDecode(sortInfo.indexv[j], listc))); + Tcl_Obj *elObj; + TclNewIntObj(elObj, TclIndexDecode(sortInfo.indexv[j], listc)); + Tcl_ListObjAppendElement(interp, itemPtr, elObj); } Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } else { @@ -3824,14 +3827,17 @@ Tcl_LsearchObjCmd( if (returnSubindices) { int j; - itemPtr = Tcl_NewWideIntObj(index+groupOffset); + TclNewIntObj(itemPtr, index+groupOffset); for (j=0 ; j<sortInfo.indexc ; j++) { - Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewWideIntObj( - TclIndexDecode(sortInfo.indexv[j], listc))); + Tcl_Obj *elObj; + TclNewIntObj(elObj, TclIndexDecode(sortInfo.indexv[j], listc)); + Tcl_ListObjAppendElement(interp, itemPtr, elObj); } Tcl_SetObjResult(interp, itemPtr); } else { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(index)); + Tcl_Obj *elObj; + TclNewIntObj(elObj, index); + Tcl_SetObjResult(interp, elObj); } } else if (index < 0) { /* @@ -4414,7 +4420,7 @@ Tcl_LsortObjCmd( idx = elementPtr->payload.index; for (j = 0; j < groupSize; j++) { if (indices) { - objPtr = Tcl_NewWideIntObj(idx + j - groupOffset); + TclNewIntObj(objPtr, idx + j - groupOffset); newArray[i++] = objPtr; Tcl_IncrRefCount(objPtr); } else { @@ -4426,7 +4432,7 @@ Tcl_LsortObjCmd( } } else if (indices) { for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { - objPtr = Tcl_NewWideIntObj(elementPtr->payload.index); + TclNewIntObj(objPtr, elementPtr->payload.index); newArray[i++] = objPtr; Tcl_IncrRefCount(objPtr); } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index f95dd12..c47490a 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -137,7 +137,7 @@ Tcl_RegexpObjCmd( "-expanded", "-line", "-linestop", "-lineanchor", "-nocase", "-start", "--", NULL }; - enum options { + enum regexpoptions { REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE, REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR, REGEXP_NOCASE, REGEXP_START, REGEXP_LAST @@ -162,7 +162,7 @@ Tcl_RegexpObjCmd( &index) != TCL_OK) { goto optionError; } - switch ((enum options) index) { + switch ((enum regexpoptions) index) { case REGEXP_ALL: all = 1; break; @@ -357,7 +357,7 @@ Tcl_RegexpObjCmd( objc = info.nsubs + 1; if (all <= 1) { - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); } } for (i = 0; i < objc; i++) { @@ -389,8 +389,8 @@ Tcl_RegexpObjCmd( end = -1; } - objs[0] = Tcl_NewWideIntObj(start); - objs[1] = Tcl_NewWideIntObj(end); + TclNewIntObj(objs[0], start); + TclNewIntObj(objs[1], end); newPtr = Tcl_NewListObj(2, objs); } else { @@ -399,7 +399,7 @@ Tcl_RegexpObjCmd( offset + info.matches[i].start, offset + info.matches[i].end - 1); } else { - newPtr = Tcl_NewObj(); + TclNewObj(newPtr); } } if (doinline) { @@ -499,7 +499,7 @@ Tcl_RegsubObjCmd( "-linestop", "-lineanchor", "-nocase", "-start", "--", NULL }; - enum options { + enum regsubobjoptions { REGSUB_ALL, REGSUB_COMMAND, REGSUB_EXPANDED, REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_NOCASE, REGSUB_START, REGSUB_LAST @@ -523,7 +523,7 @@ Tcl_RegsubObjCmd( TCL_EXACT, &index) != TCL_OK) { goto optionError; } - switch ((enum options) index) { + switch ((enum regsubobjoptions) index) { case REGSUB_ALL: all = 1; break; @@ -788,7 +788,7 @@ Tcl_RegsubObjCmd( args[idx + numParts] = Tcl_NewUnicodeObj( wstring + offset + subStart, subEnd - subStart); } else { - args[idx + numParts] = Tcl_NewObj(); + TclNewObj(args[idx + numParts]); } Tcl_IncrRefCount(args[idx + numParts]); } @@ -1194,7 +1194,7 @@ Tcl_SplitObjCmd( stringPtr = TclGetStringFromObj(objv[1], &stringLen); end = stringPtr + stringLen; - listPtr = Tcl_NewObj(); + TclNewObj(listPtr); if (stringLen == 0) { /* @@ -1536,7 +1536,7 @@ StringIsCmd( "space", "true", "upper", "wideinteger", "wordchar", "xdigit", NULL }; - enum isClasses { + enum isClassesEnum { STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, @@ -1547,7 +1547,7 @@ StringIsCmd( static const char *const isOptions[] = { "-strict", "-failindex", NULL }; - enum isOptions { + enum isOptionsEnum { OPT_STRICT, OPT_FAILIDX }; @@ -1569,7 +1569,7 @@ StringIsCmd( &idx2) != TCL_OK) { return TCL_ERROR; } - switch ((enum isOptions) idx2) { + switch ((enum isOptionsEnum) idx2) { case OPT_STRICT: strict = 1; break; @@ -1598,7 +1598,7 @@ StringIsCmd( * When entering here, result == 1 and failat == 0. */ - switch ((enum isClasses) index) { + switch ((enum isClassesEnum) index) { case STR_IS_ALNUM: chcomp = Tcl_UniCharIsAlnum; break; @@ -1906,10 +1906,11 @@ StringIsCmd( */ str_is_done: - if ((result == 0) && (failVarObj != NULL) && - Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(failat), - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; + if ((result == 0) && (failVarObj != NULL)) { + TclNewIntObj(objPtr, failat); + if (Tcl_ObjSetVar2(interp, failVarObj, NULL, objPtr, TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); return TCL_OK; @@ -2501,6 +2502,7 @@ StringStartCmd( int ch; const char *p, *string; int cur, index, length, numChars; + Tcl_Obj *obj; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "string index"); @@ -2540,7 +2542,8 @@ StringStartCmd( cur += 1; } } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(cur)); + TclNewIntObj(obj, cur); + Tcl_SetObjResult(interp, obj); return TCL_OK; } @@ -2571,6 +2574,7 @@ StringEndCmd( int ch; const char *p, *end, *string; int cur, index, length, numChars; + Tcl_Obj *obj; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "string index"); @@ -2601,7 +2605,8 @@ StringEndCmd( } else { cur = numChars; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(cur)); + TclNewIntObj(obj, cur); + Tcl_SetObjResult(interp, obj); return TCL_OK; } @@ -3479,7 +3484,7 @@ TclNRSwitchObjCmd( "-exact", "-glob", "-indexvar", "-matchvar", "-nocase", "-regexp", "--", NULL }; - enum options { + enum switchOptionsEnum { OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP, OPT_LAST }; @@ -3500,7 +3505,7 @@ TclNRSwitchObjCmd( &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum options) index) { + switch ((enum switchOptionsEnum) index) { /* * General options. */ @@ -3770,10 +3775,11 @@ TclNRSwitchObjCmd( Tcl_Obj *rangeObjAry[2]; if (info.matches[j].end > 0) { - rangeObjAry[0] = Tcl_NewWideIntObj(info.matches[j].start); - rangeObjAry[1] = Tcl_NewWideIntObj(info.matches[j].end-1); + TclNewIntObj(rangeObjAry[0], info.matches[j].start); + TclNewIntObj(rangeObjAry[1], info.matches[j].end-1); } else { - rangeObjAry[0] = rangeObjAry[1] = Tcl_NewWideIntObj(-1); + TclNewIntObj(rangeObjAry[1], TCL_INDEX_NONE); + rangeObjAry[0] = rangeObjAry[1]; } /* @@ -4165,7 +4171,7 @@ Tcl_TimeRateObjCmd( static const char *const options[] = { "-direct", "-overhead", "-calibrate", "--", NULL }; - enum options { + enum timeRateOptionsEnum { TMRT_EV_DIRECT, TMRT_OVERHEAD, TMRT_CALIBRATE, TMRT_LAST }; NRE_callback *rootPtr; @@ -4182,7 +4188,7 @@ Tcl_TimeRateObjCmd( i++; break; } - switch (index) { + switch ((enum timeRateOptionsEnum)index) { case TMRT_EV_DIRECT: direct = objv[i]; break; @@ -4197,6 +4203,8 @@ Tcl_TimeRateObjCmd( case TMRT_CALIBRATE: calibrate = objv[i]; break; + case TMRT_LAST: + break; } } @@ -4542,7 +4550,8 @@ Tcl_TimeRateObjCmd( #endif /* TCL_WIDE_CLICKS */ if (!count) { /* no iterations - avoid divide by zero */ - objs[0] = objs[2] = objs[4] = Tcl_NewWideIntObj(0); + TclNewIntObj(objs[4], 0); + objs[0] = objs[2] = objs[4]; goto retRes; } @@ -4583,7 +4592,7 @@ Tcl_TimeRateObjCmd( val = usec / count; /* microsecs per iteration */ if (val >= 1000000) { - objs[0] = Tcl_NewWideIntObj(val); + TclNewIntObj(objs[0], val); } else { if (val < 10) { digits = 6; @@ -4599,7 +4608,7 @@ Tcl_TimeRateObjCmd( objs[0] = Tcl_ObjPrintf("%.*f", digits, ((double) usec)/count); } - objs[2] = Tcl_NewWideIntObj(count); /* iterations */ + TclNewIntObj(objs[2], count); /* iterations */ /* * Calculate speed as rate (count) per sec @@ -4621,7 +4630,7 @@ Tcl_TimeRateObjCmd( objs[4] = Tcl_ObjPrintf("%.*f", digits, ((double) (count * 1000000)) / usec); } else { - objs[4] = Tcl_NewWideIntObj(val); + TclNewIntObj(objs[4], val); } } else { objs[4] = Tcl_NewWideIntObj((count / usec) * 1000000); @@ -4636,7 +4645,7 @@ Tcl_TimeRateObjCmd( if (usec >= 1) { objs[6] = Tcl_ObjPrintf("%.3f", (double)usec / 1000); } else { - objs[6] = Tcl_NewWideIntObj(0); + TclNewIntObj(objs[6], 0); } TclNewLiteralStringObj(objs[7], "net-ms"); } @@ -4714,7 +4723,7 @@ TclNRTryObjCmd( return TCL_ERROR; } bodyObj = objv[1]; - handlersObj = Tcl_NewObj(); + TclNewObj(handlersObj); bodyShared = 0; haveHandlers = 0; for (i=2 ; i<objc ; i++) { diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 37adcef..beee208 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -298,7 +298,7 @@ TclCompileArraySetCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); dataTokenPtr = TokenAfter(varTokenPtr); - literalObj = Tcl_NewObj(); + TclNewObj(literalObj); isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj); isDataValid = (isDataLiteral && Tcl_ListObjLength(NULL, literalObj, &len) == TCL_OK); @@ -390,9 +390,9 @@ TclCompileArraySetCmd( keyVar = AnonymousLocal(envPtr); valVar = AnonymousLocal(envPtr); - infoPtr = (ForeachInfo *)ckalloc(sizeof(ForeachInfo)); + infoPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *)); infoPtr->numLists = 1; - infoPtr->varLists[0] = (ForeachVarList *)ckalloc(sizeof(ForeachVarList) + sizeof(int)); + infoPtr->varLists[0] = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes) + 2 * sizeof(int)); infoPtr->varLists[0]->numVars = 2; infoPtr->varLists[0]->varIndexes[0] = keyVar; infoPtr->varLists[0]->varIndexes[1] = valVar; @@ -875,10 +875,10 @@ TclCompileConcatCmd( * implement with a simple push. */ - listObj = Tcl_NewObj(); + TclNewObj(listObj); for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { tokenPtr = TokenAfter(tokenPtr); - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(listObj); @@ -1301,10 +1301,10 @@ TclCompileDictCreateCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); - dictObj = Tcl_NewObj(); + TclNewObj(dictObj); Tcl_IncrRefCount(dictObj); for (i=1 ; i<parsePtr->numWords ; i+=2) { - keyObj = Tcl_NewObj(); + TclNewObj(keyObj); Tcl_IncrRefCount(keyObj); if (!TclWordKnownAtCompileTime(tokenPtr, keyObj)) { Tcl_DecrRefCount(keyObj); @@ -1312,7 +1312,7 @@ TclCompileDictCreateCmd( goto nonConstant; } tokenPtr = TokenAfter(tokenPtr); - valueObj = Tcl_NewObj(); + TclNewObj(valueObj); Tcl_IncrRefCount(valueObj); if (!TclWordKnownAtCompileTime(tokenPtr, valueObj)) { Tcl_DecrRefCount(keyObj); @@ -1789,7 +1789,7 @@ TclCompileDictUpdateCmd( * that are to be used. */ - duiPtr = (DictUpdateInfo *)ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1)); + duiPtr = (DictUpdateInfo *)ckalloc(offsetof(DictUpdateInfo, varIndices) + sizeof(int) * numVars); duiPtr->length = numVars; keyTokenPtrs = (Tcl_Token **)TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars); tokenPtr = TokenAfter(dictVarTokenPtr); @@ -2271,7 +2271,7 @@ DupDictUpdateInfo( size_t len; dui1Ptr = (DictUpdateInfo *)clientData; - len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1); + len = offsetof(DictUpdateInfo, varIndices) + sizeof(int) * dui1Ptr->length; dui2Ptr = (DictUpdateInfo *)ckalloc(len); memcpy(dui2Ptr, dui1Ptr, len); return dui2Ptr; @@ -2311,11 +2311,12 @@ DisassembleDictUpdateInfo( { DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData; int i; - Tcl_Obj *variables = Tcl_NewObj(); + Tcl_Obj *variables; + TclNewObj(variables); for (i=0 ; i<duiPtr->length ; i++) { Tcl_ListObjAppendElement(NULL, variables, - Tcl_NewIntObj(duiPtr->varIndices[i])); + Tcl_NewWideIntObj(duiPtr->varIndices[i])); } Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1), variables); @@ -2721,8 +2722,8 @@ CompileEachloopCmd( */ numLists = (numWords - 2)/2; - infoPtr = (ForeachInfo *)ckalloc(sizeof(ForeachInfo) - + (numLists - 1) * sizeof(ForeachVarList *)); + infoPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists) + + numLists * sizeof(ForeachVarList *)); infoPtr->numLists = 0; /* Count this up as we go */ /* @@ -2731,7 +2732,7 @@ CompileEachloopCmd( * a scalar, or if any var list needs substitutions. */ - varListObj = Tcl_NewObj(); + TclNewObj(varListObj); for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { @@ -2755,8 +2756,8 @@ CompileEachloopCmd( goto done; } - varListPtr = (ForeachVarList *)ckalloc(sizeof(ForeachVarList) - + (numVars - 1) * sizeof(int)); + varListPtr = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes) + + numVars * sizeof(int)); varListPtr->numVars = numVars; infoPtr->varLists[i/2] = varListPtr; infoPtr->numLists++; @@ -2891,7 +2892,7 @@ DupForeachInfo( ForeachVarList *srcListPtr, *dupListPtr; int numVars, i, j, numLists = srcPtr->numLists; - dupPtr = (ForeachInfo *)ckalloc(sizeof(ForeachInfo) + dupPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists) + numLists * sizeof(ForeachVarList *)); dupPtr->numLists = numLists; dupPtr->firstValueTemp = srcPtr->firstValueTemp; @@ -2900,7 +2901,7 @@ DupForeachInfo( for (i = 0; i < numLists; i++) { srcListPtr = srcPtr->varLists[i]; numVars = srcListPtr->numVars; - dupListPtr = (ForeachVarList *)ckalloc(sizeof(ForeachVarList) + dupListPtr = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes) + numVars * sizeof(int)); dupListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { @@ -3050,10 +3051,10 @@ DisassembleForeachInfo( * Data stores. */ - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); for (i=0 ; i<infoPtr->numLists ; i++) { Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewIntObj(infoPtr->firstValueTemp + i)); + Tcl_NewWideIntObj(infoPtr->firstValueTemp + i)); } Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", -1), objPtr); @@ -3062,19 +3063,19 @@ DisassembleForeachInfo( */ Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1), - Tcl_NewIntObj(infoPtr->loopCtTemp)); + Tcl_NewWideIntObj(infoPtr->loopCtTemp)); /* * Assignment targets. */ - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); for (i=0 ; i<infoPtr->numLists ; i++) { - innerPtr = Tcl_NewObj(); + TclNewObj(innerPtr); varsPtr = infoPtr->varLists[i]; for (j=0 ; j<varsPtr->numVars ; j++) { Tcl_ListObjAppendElement(NULL, innerPtr, - Tcl_NewIntObj(varsPtr->varIndexes[j])); + Tcl_NewWideIntObj(varsPtr->varIndexes[j])); } Tcl_ListObjAppendElement(NULL, objPtr, innerPtr); } @@ -3098,19 +3099,19 @@ DisassembleNewForeachInfo( */ Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpOffset", -1), - Tcl_NewIntObj(infoPtr->loopCtTemp)); + Tcl_NewWideIntObj(infoPtr->loopCtTemp)); /* * Assignment targets. */ - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); for (i=0 ; i<infoPtr->numLists ; i++) { - innerPtr = Tcl_NewObj(); + TclNewObj(innerPtr); varsPtr = infoPtr->varLists[i]; for (j=0 ; j<varsPtr->numVars ; j++) { Tcl_ListObjAppendElement(NULL, innerPtr, - Tcl_NewIntObj(varsPtr->varIndexes[j])); + Tcl_NewWideIntObj(varsPtr->varIndexes[j])); } Tcl_ListObjAppendElement(NULL, objPtr, innerPtr); } @@ -3163,7 +3164,7 @@ TclCompileFormatCmd( * a case we can handle by compiling to a constant. */ - formatObj = Tcl_NewObj(); + TclNewObj(formatObj); Tcl_IncrRefCount(formatObj); tokenPtr = TokenAfter(tokenPtr); if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) { @@ -3174,7 +3175,7 @@ TclCompileFormatCmd( objv = (Tcl_Obj **)ckalloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *)); for (i=0 ; i+2 < parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); - objv[i] = Tcl_NewObj(); + TclNewObj(objv[i]); Tcl_IncrRefCount(objv[i]); if (!TclWordKnownAtCompileTime(tokenPtr, objv[i])) { goto checkForStringConcatCase; @@ -3266,7 +3267,7 @@ TclCompileFormatCmd( start = Tcl_GetString(formatObj); /* The start of the currently-scanned literal * in the format string. */ - tmpObj = Tcl_NewObj(); /* The buffer used to accumulate the literal + TclNewObj(tmpObj); /* The buffer used to accumulate the literal * being built. */ for (bytes = start ; *bytes ; bytes++) { if (*bytes == '%') { @@ -3284,7 +3285,7 @@ TclCompileFormatCmd( if (len > 0) { PushLiteral(envPtr, b, len); Tcl_DecrRefCount(tmpObj); - tmpObj = Tcl_NewObj(); + TclNewObj(tmpObj); i++; } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 3361d7f..780f7b8 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -53,9 +53,10 @@ TclGetIndexFromToken( int after, int *indexPtr) { - Tcl_Obj *tmpObj = Tcl_NewObj(); + Tcl_Obj *tmpObj; int result = TCL_ERROR; + TclNewObj(tmpObj); if (TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { result = TclIndexEncode(NULL, tmpObj, before, after, indexPtr); } @@ -598,7 +599,7 @@ TclCompileInfoCommandsCmd( return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { goto notCompilable; @@ -873,7 +874,7 @@ TclCompileLappendCmd( */ if (numWords > 2) { - Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr); + valueTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, valueTokenPtr, interp, 2); } @@ -1169,9 +1170,9 @@ TclCompileListCmd( numWords = parsePtr->numWords; valueTokenPtr = TokenAfter(parsePtr->tokenPtr); - listObj = Tcl_NewObj(); + TclNewObj(listObj); for (i = 1; i < numWords && listObj != NULL; i++) { - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); if (TclWordKnownAtCompileTime(valueTokenPtr, objPtr)) { (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr); } else { @@ -2264,7 +2265,7 @@ TclCompileRegsubCmd( Tcl_DStringInit(&pattern); tokenPtr = TokenAfter(tokenPtr); - patternObj = Tcl_NewObj(); + TclNewObj(patternObj); if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { goto done; } @@ -2275,7 +2276,7 @@ TclCompileRegsubCmd( } tokenPtr = TokenAfter(tokenPtr); Tcl_DecrRefCount(patternObj); - patternObj = Tcl_NewObj(); + TclNewObj(patternObj); if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { goto done; } @@ -2290,7 +2291,7 @@ TclCompileRegsubCmd( stringTokenPtr = TokenAfter(tokenPtr); tokenPtr = TokenAfter(stringTokenPtr); - replacementObj = Tcl_NewObj(); + TclNewObj(replacementObj); if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) { goto done; } @@ -2440,7 +2441,7 @@ TclCompileReturnCmd( */ for (objc = 0; objc < numOptionWords; objc++) { - objv[objc] = Tcl_NewObj(); + TclNewObj(objv[objc]); Tcl_IncrRefCount(objv[objc]); if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { /* @@ -2659,7 +2660,7 @@ TclCompileUpvarCmd( * Push the frame index if it is known at compile time */ - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); tokenPtr = TokenAfter(parsePtr->tokenPtr); if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { CallFrame *framePtr; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 81c01e0..fe661f8 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -241,7 +241,7 @@ TclCompileStringCatCmd( folded = NULL; wordTokenPtr = TokenAfter(parsePtr->tokenPtr); for (i = 1; i < numWords; i++) { - obj = Tcl_NewObj(); + TclNewObj(obj); if (TclWordKnownAtCompileTime(wordTokenPtr, obj)) { if (folded) { Tcl_AppendObjToObj(folded, obj); @@ -511,7 +511,7 @@ TclCompileStringIsCmd( "true", "upper", "wideinteger", "wordchar", "xdigit", NULL }; - enum isClasses { + enum isClassesEnum { STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, @@ -526,7 +526,7 @@ TclCompileStringIsCmd( if (parsePtr->numWords < 3 || parsePtr->numWords > 6) { return TCL_ERROR; } - isClass = Tcl_NewObj(); + TclNewObj(isClass); if (!TclWordKnownAtCompileTime(tokenPtr, isClass)) { Tcl_DecrRefCount(isClass); return TCL_ERROR; @@ -575,7 +575,7 @@ TclCompileStringIsCmd( CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); - switch ((enum isClasses) t) { + switch ((enum isClassesEnum) t) { case STR_IS_ALNUM: strClassType = STR_CLASS_ALNUM; goto compileStrClass; @@ -930,7 +930,7 @@ TclCompileStringMapCmd( } mapTokenPtr = TokenAfter(parsePtr->tokenPtr); stringTokenPtr = TokenAfter(mapTokenPtr); - mapObj = Tcl_NewObj(); + TclNewObj(mapObj); Tcl_IncrRefCount(mapObj); if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) { Tcl_DecrRefCount(mapObj); @@ -1461,7 +1461,7 @@ TclCompileSubstCmd( objv = (Tcl_Obj **)TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *)); for (objc = 0; objc < /*numArgs*/ numOpts; objc++) { - objv[objc] = Tcl_NewObj(); + TclNewObj(objv[objc]); Tcl_IncrRefCount(objv[objc]); if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { objc++; @@ -2610,18 +2610,19 @@ DisassembleJumptableInfo( TCL_UNUSED(unsigned int)) { JumptableInfo *jtPtr = (JumptableInfo *)clientData; - Tcl_Obj *mapping = Tcl_NewObj(); + Tcl_Obj *mapping; Tcl_HashEntry *hPtr; Tcl_HashSearch search; const char *keyPtr; - int offset; + size_t offset; + TclNewObj(mapping); hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { keyPtr = (const char *)Tcl_GetHashKey(&jtPtr->hashTable, hPtr); offset = PTR2INT(Tcl_GetHashValue(hPtr)); Tcl_DictObjPut(NULL, mapping, Tcl_NewStringObj(keyPtr, -1), - Tcl_NewIntObj(offset)); + Tcl_NewWideIntObj(offset)); } Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", -1), mapping); } @@ -3623,8 +3624,9 @@ TclCompileUnsetCmd( */ for (i=1,varTokenPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) { - Tcl_Obj *leadingWord = Tcl_NewObj(); + Tcl_Obj *leadingWord; + TclNewObj(leadingWord); varTokenPtr = TokenAfter(varTokenPtr); if (!TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { TclDecrRefCount(leadingWord); diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 30ca876..41938e3 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -752,7 +752,7 @@ ParseExpr( /* * Tricky case: see test expr-62.10 */ - + int scanned2 = scanned; do { scanned2 += TclParseAllWhiteSpace( @@ -1042,7 +1042,7 @@ ParseExpr( * later. */ - literal = Tcl_NewObj(); + TclNewObj(literal); if (TclWordKnownAtCompileTime(tokenPtr, literal)) { Tcl_ListObjAppendElement(NULL, litList, literal); complete = lastParsed = OT_LITERAL; @@ -1869,11 +1869,13 @@ Tcl_ParseExpr( { int code; OpNode *opTree = NULL; /* Will point to the tree of operators. */ - Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals. */ - Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names. */ + Tcl_Obj *litList; /* List to hold the literals. */ + Tcl_Obj *funcList; /* List to hold the functon names. */ Tcl_Parse *exprParsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse)); /* Holds the Tcl_Tokens of substitutions. */ + TclNewObj(litList); + TclNewObj(funcList); if (numBytes < 0) { numBytes = (start ? strlen(start) : 0); } @@ -2083,7 +2085,7 @@ ParseLexeme( break; } - literal = Tcl_NewObj(); + TclNewObj(literal); if (TclParseNumber(NULL, literal, NULL, start, numBytes, &end, TCL_PARSE_NO_WHITESPACE) == TCL_OK) { if (end < start + numBytes && !TclIsBareword(*end)) { @@ -2197,12 +2199,15 @@ TclCompileExpr( int optimize) /* 0 for one-off expressions. */ { OpNode *opTree = NULL; /* Will point to the tree of operators */ - Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */ - Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names*/ + Tcl_Obj *litList; /* List to hold the literals */ + Tcl_Obj *funcList; /* List to hold the functon names*/ Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse)); /* Holds the Tcl_Tokens of substitutions */ + int code; - int code = ParseExpr(interp, script, numBytes, &opTree, litList, + TclNewObj(litList); + TclNewObj(funcList); + code = ParseExpr(interp, script, numBytes, &opTree, litList, funcList, parsePtr, 0 /* parseOnly */); if (code == TCL_OK) { @@ -2501,8 +2506,8 @@ CompileExprTree( if (optimize) { int length; const char *bytes = TclGetStringFromObj(literal, &length); - int index = TclRegisterLiteral(envPtr, bytes, length, 0); - Tcl_Obj *objPtr = TclFetchLiteral(envPtr, index); + int idx = TclRegisterLiteral(envPtr, bytes, length, 0); + Tcl_Obj *objPtr = TclFetchLiteral(envPtr, idx); if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) { /* @@ -2522,7 +2527,7 @@ CompileExprTree( objPtr->internalRep = literal->internalRep; literal->typePtr = NULL; } - TclEmitPush(index, envPtr); + TclEmitPush(idx, envPtr); } else { /* * When optimize==0, we know the expression is a one-off and @@ -2548,7 +2553,7 @@ CompileExprTree( if (ExecConstantExprTree(interp, nodes, next, litObjvPtr) == TCL_OK) { - int index; + int idx; Tcl_Obj *objPtr = Tcl_GetObjResult(interp); /* @@ -2562,8 +2567,8 @@ CompileExprTree( const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); - index = TclRegisterLiteral(envPtr, bytes, numBytes, 0); - tableValue = TclFetchLiteral(envPtr, index); + idx = TclRegisterLiteral(envPtr, bytes, numBytes, 0); + tableValue = TclFetchLiteral(envPtr, idx); if ((tableValue->typePtr == NULL) && (objPtr->typePtr != NULL)) { /* @@ -2575,9 +2580,9 @@ CompileExprTree( objPtr->typePtr = NULL; } } else { - index = TclAddLiteralObj(envPtr, objPtr, NULL); + idx = TclAddLiteralObj(envPtr, objPtr, NULL); } - TclEmitPush(index, envPtr); + TclEmitPush(idx, envPtr); } else { TclCompileSyntaxError(interp, envPtr); } @@ -2754,7 +2759,7 @@ TclVariadicOpCmd( int code; if (objc < 2) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(occdPtr->i.identity)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(occdPtr->i.identity)); return TCL_OK; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 9d1c56d..2ab92da 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -848,7 +848,7 @@ TclSetByteCodeFromAny( * faster code in some cases, and more compact code in more. */ - if (Tcl_GetMaster(interp) == NULL && + if (Tcl_GetParent(interp) == NULL && !Tcl_LimitTypeEnabled(interp, TCL_LIMIT_COMMANDS|TCL_LIMIT_TIME) && IsCompactibleCompileEnv(&compEnv)) { TclFreeCompileEnv(&compEnv); @@ -1746,7 +1746,7 @@ TclWordKnownAtCompileTime( } tokenPtr++; if (valuePtr != NULL) { - tempPtr = Tcl_NewObj(); + TclNewObj(tempPtr); Tcl_IncrRefCount(tempPtr); } while (numComponents--) { @@ -1834,7 +1834,7 @@ CompileCmdLiteral( bytes = TclGetStringFromObj(cmdObj, &numBytes); cmdLitIdx = TclRegisterLiteral(envPtr, bytes, numBytes, extraLiteralFlags); - if (cmdPtr) { + if (cmdPtr && TclRoutineHasName(cmdPtr)) { TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); } TclEmitPush(cmdLitIdx, envPtr); @@ -2035,7 +2035,7 @@ CompileCommandTokens( Interp *iPtr = (Interp *) interp; Tcl_Token *tokenPtr = parsePtr->tokenPtr; ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; - Tcl_Obj *cmdObj = Tcl_NewObj(); + Tcl_Obj *cmdObj; Command *cmdPtr = NULL; int code = TCL_ERROR; int cmdKnown, expand = -1; @@ -2050,6 +2050,7 @@ CompileCommandTokens( /* Pre-Compile */ + TclNewObj(cmdObj); envPtr->numCommands++; EnterCmdStartData(envPtr, cmdIdx, parsePtr->commandStart - envPtr->source, startCodeOffset); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5c1b67c..21a27f7 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -991,7 +991,7 @@ typedef struct JumpFixupArray { typedef struct ForeachVarList { int numVars; /* The number of variables in the list. */ - int varIndexes[1]; /* An array of the indexes ("slot numbers") + int varIndexes[TCLFLEXARRAY];/* An array of the indexes ("slot numbers") * for each variable in the procedure's array * of local variables. Only scalar variables * are supported. The actual size of this @@ -1015,7 +1015,7 @@ typedef struct ForeachInfo { * the loop's iteration count. Used to * determine next value list element to assign * each loop var. */ - ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList + ForeachVarList *varLists[TCLFLEXARRAY];/* An array of pointers to ForeachVarList * structures describing each var list. The * actual size of this field will be large * enough to numVars indexes. THIS MUST BE THE @@ -1046,7 +1046,7 @@ MODULE_SCOPE const AuxDataType tclJumptableInfoType; typedef struct { int length; /* Size of array */ - int varIndices[1]; /* Array of variable indices to manage when + int varIndices[TCLFLEXARRAY]; /* Array of variable indices to manage when * processing the start and end of a [dict * update]. There is really more than one * entry, and the structure is allocated to diff --git a/generic/tclDate.c b/generic/tclDate.c index f8552a3..7f659eb 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -2787,7 +2787,7 @@ TclClockOldscanObjCmd( yyHaveRel = 0; yyRelMonth = 0; yyRelDay = 0; yyRelSeconds = 0; yyRelPointer = NULL; - dateInfo.messages = Tcl_NewObj(); + TclNewObj(dateInfo.messages); dateInfo.separatrix = ""; Tcl_IncrRefCount(dateInfo.messages); @@ -2844,8 +2844,8 @@ TclClockOldscanObjCmd( return TCL_ERROR; } - result = Tcl_NewObj(); - resultElement = Tcl_NewObj(); + TclNewObj(result); + TclNewObj(resultElement); if (yyHaveDate) { Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj((int) yyYear)); @@ -2863,7 +2863,7 @@ TclClockOldscanObjCmd( Tcl_ListObjAppendElement(interp, result, Tcl_NewObj()); } - resultElement = Tcl_NewObj(); + TclNewObj(resultElement); if (yyHaveZone) { Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj((int) -yyTimezone)); @@ -2872,7 +2872,7 @@ TclClockOldscanObjCmd( } Tcl_ListObjAppendElement(interp, result, resultElement); - resultElement = Tcl_NewObj(); + TclNewObj(resultElement); if (yyHaveRel) { Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj((int) yyRelMonth)); @@ -2883,7 +2883,7 @@ TclClockOldscanObjCmd( } Tcl_ListObjAppendElement(interp, result, resultElement); - resultElement = Tcl_NewObj(); + TclNewObj(resultElement); if (yyHaveDay && !yyHaveDate) { Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj((int) yyDayOrdinal)); @@ -2892,7 +2892,7 @@ TclClockOldscanObjCmd( } Tcl_ListObjAppendElement(interp, result, resultElement); - resultElement = Tcl_NewObj(); + TclNewObj(resultElement); if (yyHaveOrdinalMonth) { Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj((int) yyMonthOrdinal)); diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 8e8df30..9ea6838 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -300,13 +300,13 @@ EXTERN int Tcl_ConvertElement(const char *src, char *dst, EXTERN int Tcl_ConvertCountedElement(const char *src, int length, char *dst, int flags); /* 86 */ -EXTERN int Tcl_CreateAlias(Tcl_Interp *slave, - const char *slaveCmd, Tcl_Interp *target, +EXTERN int Tcl_CreateAlias(Tcl_Interp *childInterp, + const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 87 */ -EXTERN int Tcl_CreateAliasObj(Tcl_Interp *slave, - const char *slaveCmd, Tcl_Interp *target, +EXTERN int Tcl_CreateAliasObj(Tcl_Interp *childInterp, + const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 88 */ @@ -345,8 +345,8 @@ EXTERN Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 97 */ -EXTERN Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, - const char *slaveName, int isSafe); +EXTERN Tcl_Interp * Tcl_CreateChild(Tcl_Interp *interp, const char *name, + int isSafe); /* 98 */ EXTERN Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, Tcl_TimerProc *proc, ClientData clientData); @@ -482,13 +482,13 @@ TCL_DEPRECATED("see TIP #559. Use Tcl_ResetResult") void Tcl_FreeResult(Tcl_Interp *interp); /* 148 */ EXTERN int Tcl_GetAlias(Tcl_Interp *interp, - const char *slaveCmd, + const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 149 */ EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, - const char *slaveCmd, + const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); @@ -528,9 +528,9 @@ EXTERN int Tcl_GetErrno(void); EXTERN const char * Tcl_GetHostName(void); /* 163 */ EXTERN int Tcl_GetInterpPath(Tcl_Interp *interp, - Tcl_Interp *slaveInterp); + Tcl_Interp *childInterp); /* 164 */ -EXTERN Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp); +EXTERN Tcl_Interp * Tcl_GetParent(Tcl_Interp *interp); /* 165 */ EXTERN const char * Tcl_GetNameOfExecutable(void); /* 166 */ @@ -556,8 +556,7 @@ EXTERN int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 171 */ EXTERN int Tcl_GetServiceMode(void); /* 172 */ -EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, - const char *slaveName); +EXTERN Tcl_Interp * Tcl_GetChild(Tcl_Interp *interp, const char *name); /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel(int type); /* 174 */ @@ -2034,8 +2033,8 @@ typedef struct TclStubs { char * (*tcl_Concat) (int argc, const char *const *argv); /* 83 */ int (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */ int (*tcl_ConvertCountedElement) (const char *src, int length, char *dst, int flags); /* 85 */ - int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */ - int (*tcl_CreateAliasObj) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */ + int (*tcl_CreateAlias) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */ + int (*tcl_CreateAliasObj) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */ Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, ClientData instanceData, int mask); /* 88 */ void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData); /* 89 */ void (*tcl_CreateCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData); /* 90 */ @@ -2045,7 +2044,7 @@ typedef struct TclStubs { Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */ TCL_DEPRECATED_API("") void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */ Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ - Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, const char *slaveName, int isSafe); /* 97 */ + Tcl_Interp * (*tcl_CreateChild) (Tcl_Interp *interp, const char *name, int isSafe); /* 97 */ Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 98 */ Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData); /* 99 */ void (*tcl_DeleteAssocData) (Tcl_Interp *interp, const char *name); /* 100 */ @@ -2096,8 +2095,8 @@ typedef struct TclStubs { Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */ int (*tcl_Flush) (Tcl_Channel chan); /* 146 */ TCL_DEPRECATED_API("see TIP #559. Use Tcl_ResetResult") void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ - int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */ - int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ + int (*tcl_GetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */ + int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ ClientData (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */ int (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */ @@ -2111,8 +2110,8 @@ typedef struct TclStubs { const char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ int (*tcl_GetErrno) (void); /* 161 */ const char * (*tcl_GetHostName) (void); /* 162 */ - int (*tcl_GetInterpPath) (Tcl_Interp *interp, Tcl_Interp *slaveInterp); /* 163 */ - Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */ + int (*tcl_GetInterpPath) (Tcl_Interp *interp, Tcl_Interp *childInterp); /* 163 */ + Tcl_Interp * (*tcl_GetParent) (Tcl_Interp *interp); /* 164 */ const char * (*tcl_GetNameOfExecutable) (void); /* 165 */ Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */ #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ @@ -2128,7 +2127,7 @@ typedef struct TclStubs { int (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */ int (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */ int (*tcl_GetServiceMode) (void); /* 171 */ - Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */ + Tcl_Interp * (*tcl_GetChild) (Tcl_Interp *interp, const char *name); /* 172 */ Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */ const char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */ TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */ @@ -2825,8 +2824,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_CreateMathFunc) /* 95 */ #define Tcl_CreateObjCommand \ (tclStubsPtr->tcl_CreateObjCommand) /* 96 */ -#define Tcl_CreateSlave \ - (tclStubsPtr->tcl_CreateSlave) /* 97 */ +#define Tcl_CreateChild \ + (tclStubsPtr->tcl_CreateChild) /* 97 */ #define Tcl_CreateTimerHandler \ (tclStubsPtr->tcl_CreateTimerHandler) /* 98 */ #define Tcl_CreateTrace \ @@ -2959,8 +2958,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetHostName) /* 162 */ #define Tcl_GetInterpPath \ (tclStubsPtr->tcl_GetInterpPath) /* 163 */ -#define Tcl_GetMaster \ - (tclStubsPtr->tcl_GetMaster) /* 164 */ +#define Tcl_GetParent \ + (tclStubsPtr->tcl_GetParent) /* 164 */ #define Tcl_GetNameOfExecutable \ (tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */ #define Tcl_GetObjResult \ @@ -2981,8 +2980,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetsObj) /* 170 */ #define Tcl_GetServiceMode \ (tclStubsPtr->tcl_GetServiceMode) /* 171 */ -#define Tcl_GetSlave \ - (tclStubsPtr->tcl_GetSlave) /* 172 */ +#define Tcl_GetChild \ + (tclStubsPtr->tcl_GetChild) /* 172 */ #define Tcl_GetStdChannel \ (tclStubsPtr->tcl_GetStdChannel) /* 173 */ #define Tcl_GetStringResult \ @@ -4183,5 +4182,8 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfCharComplete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \ ? ((length) >= 4) : tclStubsPtr->tcl_UtfCharComplete((src), (length))) #endif +#define Tcl_CreateSlave Tcl_CreateChild +#define Tcl_GetSlave Tcl_GetChild +#define Tcl_GetMaster Tcl_GetParent #endif /* _TCLDECLS */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index f63d60d..9c11df6 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -2037,7 +2037,7 @@ DictSizeCmd( } result = Tcl_DictObjSize(interp, objv[1], &size); if (result == TCL_OK) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(size)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(size)); } return result; } @@ -2212,7 +2212,7 @@ DictIncrCmd( Tcl_DictObjPut(NULL, dictPtr, objv[2], objv[3]); } } else { - Tcl_DictObjPut(NULL, dictPtr, objv[2], Tcl_NewIntObj(1)); + Tcl_DictObjPut(NULL, dictPtr, objv[2], Tcl_NewWideIntObj(1)); } } else { /* @@ -2226,8 +2226,9 @@ DictIncrCmd( if (objc == 4) { code = TclIncrObj(interp, valuePtr, objv[3]); } else { - Tcl_Obj *incrPtr = Tcl_NewIntObj(1); + Tcl_Obj *incrPtr; + TclNewIntObj(incrPtr, 1); Tcl_IncrRefCount(incrPtr); code = TclIncrObj(interp, valuePtr, incrPtr); TclDecrRefCount(incrPtr); diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 379b427..8ccc303 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -284,7 +284,7 @@ DisassembleByteCodeObj( PrintSourceToObj(bufferObj, codePtr->source, TclMin(codePtr->numSrcBytes, 55)); GetLocationInformation(codePtr->procPtr, &fileObj, &line); - if (line > -1 && fileObj != NULL) { + if (line >= 0 && fileObj != NULL) { Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d", Tcl_GetString(fileObj), line); } @@ -804,8 +804,9 @@ Tcl_Obj * TclNewInstNameObj( unsigned char inst) { - Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_Obj *objPtr; + TclNewObj(objPtr); TclInvalidateStringRep(objPtr); InstNameSetIntRep(objPtr, (long) inst); @@ -950,7 +951,7 @@ DisassembleByteCodeAsDicts( * Get the literals from the bytecode. */ - literals = Tcl_NewObj(); + TclNewObj(literals); for (i=0 ; i<codePtr->numLitObjects ; i++) { Tcl_ListObjAppendElement(NULL, literals, codePtr->objArrayPtr[i]); } @@ -959,7 +960,7 @@ DisassembleByteCodeAsDicts( * Get the variables from the bytecode. */ - variables = Tcl_NewObj(); + TclNewObj(variables); if (codePtr->procPtr) { int localCount = codePtr->procPtr->numCompiledLocals; CompiledLocal *localPtr = codePtr->procPtr->firstLocalPtr; @@ -967,7 +968,7 @@ DisassembleByteCodeAsDicts( for (i=0 ; i<localCount ; i++,localPtr=localPtr->nextPtr) { Tcl_Obj *descriptor[2]; - descriptor[0] = Tcl_NewObj(); + TclNewObj(descriptor[0]); if (!(localPtr->flags & (VAR_ARRAY|VAR_LINK))) { Tcl_ListObjAppendElement(NULL, descriptor[0], Tcl_NewStringObj("scalar", -1)); @@ -1007,12 +1008,12 @@ DisassembleByteCodeAsDicts( * Get the instructions from the bytecode. */ - instructions = Tcl_NewObj(); + TclNewObj(instructions); for (pc=codePtr->codeStart; pc<codePtr->codeStart+codePtr->numCodeBytes;){ const InstructionDesc *instDesc = &tclInstructionTable[*pc]; int address = pc - codePtr->codeStart; - inst = Tcl_NewObj(); + TclNewObj(inst); Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj( instDesc->name, -1)); opnd = pc + 1; @@ -1034,7 +1035,7 @@ DisassembleByteCodeAsDicts( val = TclGetUInt4AtPtr(opnd); opnd += 4; formatNumber: - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewWideIntObj(val)); break; case OPERAND_OFFSET1: @@ -1102,7 +1103,7 @@ DisassembleByteCodeAsDicts( Tcl_Panic("opcode %d with more than zero 'no' operands", *pc); } } - Tcl_DictObjPut(NULL, instructions, Tcl_NewIntObj(address), inst); + Tcl_DictObjPut(NULL, instructions, Tcl_NewWideIntObj(address), inst); pc += instDesc->numBytes; } @@ -1110,21 +1111,23 @@ DisassembleByteCodeAsDicts( * Get the auxiliary data from the bytecode. */ - aux = Tcl_NewObj(); + TclNewObj(aux); for (i=0 ; i<codePtr->numAuxDataItems ; i++) { AuxData *auxData = &codePtr->auxDataArrayPtr[i]; Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1); if (auxData->type->disassembleProc) { - Tcl_Obj *desc = Tcl_NewObj(); + Tcl_Obj *desc; + TclNewObj(desc); Tcl_DictObjPut(NULL, desc, Tcl_NewStringObj("name", -1), auxDesc); auxDesc = desc; auxData->type->disassembleProc(auxData->clientData, auxDesc, codePtr, 0); } else if (auxData->type->printProc) { - Tcl_Obj *desc = Tcl_NewObj(); + Tcl_Obj *desc; + TclNewObj(desc); auxData->type->printProc(auxData->clientData, desc, codePtr, 0); Tcl_ListObjAppendElement(NULL, auxDesc, desc); } @@ -1135,7 +1138,7 @@ DisassembleByteCodeAsDicts( * Get the exception ranges from the bytecode. */ - exn = Tcl_NewObj(); + TclNewObj(exn); for (i=0 ; i<codePtr->numExceptRanges ; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; @@ -1170,7 +1173,7 @@ DisassembleByteCodeAsDicts( ? ((ptr)+=5 , TclGetInt4AtPtr((ptr)-4)) \ : ((ptr)+=1 , TclGetInt1AtPtr((ptr)-1))) - commands = Tcl_NewObj(); + TclNewObj(commands); codeOffPtr = codePtr->codeDeltaStart; codeLenPtr = codePtr->codeLengthStart; srcOffPtr = codePtr->srcDeltaStart; @@ -1183,11 +1186,11 @@ DisassembleByteCodeAsDicts( codeLength = Decode(codeLenPtr); sourceOffset += Decode(srcOffPtr); sourceLength = Decode(srcLenPtr); - cmd = Tcl_NewObj(); + TclNewObj(cmd); Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codefrom", -1), - Tcl_NewIntObj(codeOffset)); + Tcl_NewWideIntObj(codeOffset)); Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codeto", -1), - Tcl_NewIntObj(codeOffset + codeLength - 1)); + Tcl_NewWideIntObj(codeOffset + codeLength - 1)); /* * Convert byte offsets to character offsets; important if multibyte @@ -1195,10 +1198,10 @@ DisassembleByteCodeAsDicts( */ Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1), - Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source, + Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source, sourceOffset))); Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1), - Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source, + Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source, sourceOffset + sourceLength - 1))); Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", -1), Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength)); @@ -1218,7 +1221,7 @@ DisassembleByteCodeAsDicts( * Build the overall result. */ - description = Tcl_NewObj(); + TclNewObj(description); Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("literals", -1), literals); Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("variables", -1), @@ -1234,13 +1237,13 @@ DisassembleByteCodeAsDicts( Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("namespace", -1), Tcl_NewStringObj(codePtr->nsPtr->fullName, -1)); Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("stackdepth", -1), - Tcl_NewIntObj(codePtr->maxStackDepth)); + Tcl_NewWideIntObj(codePtr->maxStackDepth)); Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1), - Tcl_NewIntObj(codePtr->maxExceptDepth)); - if (line > -1) { + Tcl_NewWideIntObj(codePtr->maxExceptDepth)); + if (line >= 0) { Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("initiallinenumber", -1), - Tcl_NewIntObj(line)); + Tcl_NewWideIntObj(line)); } if (file) { Tcl_DictObjPut(NULL, description, diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index ae02821..48ab3cf 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -116,7 +116,7 @@ typedef struct { * entry in this array is 1, otherwise it is * 0. */ int numSubTables; /* Length of following array. */ - EscapeSubTable subTables[1];/* Information about each EscapeSubTable used + EscapeSubTable subTables[TCLFLEXARRAY];/* Information about each EscapeSubTable used * by this encoding type. The actual size is * as large as necessary to hold all * EscapeSubTables. */ @@ -469,12 +469,13 @@ FillEncodingFileMap(void) */ int j, numFiles; - Tcl_Obj *directory, *matchFileList = Tcl_NewObj(); + Tcl_Obj *directory, *matchFileList; Tcl_Obj **filev; Tcl_GlobTypeData readableFiles = { TCL_GLOB_TYPE_FILE, TCL_GLOB_PERM_R, NULL, NULL }; + TclNewObj(matchFileList); Tcl_ListObjIndex(NULL, searchPath, i, &directory); Tcl_IncrRefCount(directory); Tcl_IncrRefCount(matchFileList); @@ -915,10 +916,11 @@ Tcl_GetEncodingNames( Tcl_HashTable table; Tcl_HashSearch search; Tcl_HashEntry *hPtr; - Tcl_Obj *map, *name, *result = Tcl_NewObj(); + Tcl_Obj *map, *name, *result; Tcl_DictSearch mapSearch; int dummy, done = 0; + TclNewObj(result); Tcl_InitObjHashTable(&table); /* @@ -2053,7 +2055,7 @@ LoadEscapeEncoding( Tcl_DStringFree(&lineString); } - size = sizeof(EscapeEncodingData) - sizeof(EscapeSubTable) + size = offsetof(EscapeEncodingData, subTables) + Tcl_DStringLength(&escapeData); dataPtr = (EscapeEncodingData *)ckalloc(size); dataPtr->initLen = strlen(init); diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 3c99631..23516f8 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -2909,7 +2909,7 @@ TclCompileEnsemble( DefineLineInformation; Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems; - Tcl_Obj *replaced = Tcl_NewObj(), *replacement; + Tcl_Obj *replaced, *replacement; Tcl_Command ensemble = (Tcl_Command) cmdPtr; Command *oldCmdPtr = cmdPtr, *newCmdPtr; int len, result, flags = 0, i, depth = 1, invokeAnyway = 0; @@ -2917,6 +2917,7 @@ TclCompileEnsemble( unsigned numBytes; const char *word; + TclNewObj(replaced); Tcl_IncrRefCount(replaced); if (parsePtr->numWords < depth + 1) { goto failed; @@ -3161,7 +3162,7 @@ TclCompileEnsemble( } /* - * Now we've done the mapping process, can now actually try to compile. + * Now that the mapping process is done we actually try to compile. * If there is a subcommand compiler and that successfully produces code, * we'll use that. Otherwise, we fall back to generating opcodes to do the * invoke at runtime. @@ -3261,9 +3262,9 @@ TclAttemptCompileProc( /* * Advance parsePtr->tokenPtr so that it points at the last subcommand. - * This will be wrong, but it will not matter, and it will put the - * tokens for the arguments in the right place without the needed to - * allocate a synthetic Tcl_Parse struct, or copy tokens around. + * This will be wrong but it will not matter, and it will put the + * tokens for the arguments in the right place without the need to + * allocate a synthetic Tcl_Parse struct or copy tokens around. */ for (i = 0; i < depth - 1; i++) { @@ -3420,7 +3421,7 @@ CompileToInvokedCommand( * the implementation. */ - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); bytes = TclGetString(objPtr); if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { @@ -3459,8 +3460,9 @@ CompileBasicNArgCommand( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_Obj *objPtr; + TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr, diff --git a/generic/tclEvent.c b/generic/tclEvent.c index db1f59a..76a45ae 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -311,7 +311,7 @@ HandleBgErrors( int TclDefaultBgErrorHandlerObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1046,9 +1046,9 @@ Tcl_InitSubsystems(void) * implementation of self-initializing locks. */ - TclInitThreadStorage(); /* Creates master hash table for + TclInitThreadStorage(); /* Creates hash table for * thread local storage */ -#if USE_TCLALLOC +#if defined(USE_TCLALLOC) && USE_TCLALLOC TclInitAlloc(); /* Process wide mutex init */ #endif #if TCL_THREADS && defined(USE_THREAD_ALLOC) @@ -1163,7 +1163,7 @@ Tcl_Finalize(void) TclFinalizeFilesystem(); /* - * Undo all Tcl_ObjType registrations, and reset the master list of free + * Undo all Tcl_ObjType registrations, and reset the global list of free * Tcl_Obj's. After this returns, no more Tcl_Obj's should be allocated or * freed. * @@ -1398,7 +1398,7 @@ TclInThreadExit(void) int Tcl_VwaitObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1494,7 +1494,7 @@ VwaitVarProc( int Tcl_UpdateObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1502,7 +1502,7 @@ Tcl_UpdateObjCmd( int optionIndex; int flags = 0; /* Initialized to avoid compiler warning. */ static const char *const updateOptions[] = {"idletasks", NULL}; - enum updateOptions {OPT_IDLETASKS}; + enum updateOptionsEnum {OPT_IDLETASKS}; if (objc == 1) { flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; @@ -1511,7 +1511,7 @@ Tcl_UpdateObjCmd( "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum updateOptions) optionIndex) { + switch ((enum updateOptionsEnum) optionIndex) { case OPT_IDLETASKS: flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; break; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0f1c2cc..54c147d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -855,8 +855,8 @@ TclCreateExecEnv( * [sizeof(Tcl_Obj*)] */ { ExecEnv *eePtr = (ExecEnv *)ckalloc(sizeof(ExecEnv)); - ExecStack *esPtr = (ExecStack *)ckalloc(sizeof(ExecStack) - + (size_t) (size-1) * sizeof(Tcl_Obj *)); + ExecStack *esPtr = (ExecStack *)ckalloc(offsetof(ExecStack, stackWords) + + size * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; TclNewIntObj(eePtr->constants[0], 0); @@ -1121,7 +1121,7 @@ GrowEvaluationStack( newElems = needed; #endif - newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *); + newBytes = offsetof(ExecStack, stackWords) + newElems * sizeof(Tcl_Obj *); oldPtr = esPtr; esPtr = (ExecStack *)ckalloc(newBytes); @@ -3736,7 +3736,7 @@ TEBCresume( TRACE(("%u %ld => ", opnd, increment)); if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared. */ - objResultPtr = Tcl_NewWideIntObj(w+increment); + TclNewIntObj(objResultPtr, w + increment); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { @@ -4464,7 +4464,7 @@ TEBCresume( CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; TclNewObj(objResultPtr); - if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) { + if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) { Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, objResultPtr); } @@ -4524,6 +4524,18 @@ TEBCresume( TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); if (cmd == NULL) { + goto instOriginError; + } + origCmd = TclGetOriginalCommand(cmd); + if (origCmd == NULL) { + origCmd = cmd; + } + + TclNewObj(objResultPtr); + Tcl_GetCommandFullName(interp, origCmd, objResultPtr); + if (TclCheckEmptyString(objResultPtr) == TCL_EMPTYSTRING_YES ) { + Tcl_DecrRefCount(objResultPtr); + instOriginError: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid command name \"%s\"", TclGetString(OBJ_AT_TOS))); DECACHE_STACK_INFO(); @@ -4533,12 +4545,6 @@ TEBCresume( TRACE_APPEND(("ERROR: not command\n")); goto gotError; } - origCmd = TclGetOriginalCommand(cmd); - if (origCmd == NULL) { - origCmd = cmd; - } - TclNewObj(objResultPtr); - Tcl_GetCommandFullName(interp, origCmd, objResultPtr); TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS))); NEXT_INST_F(1, 1, 1); } @@ -4857,13 +4863,19 @@ TEBCresume( */ if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) - && !TclHasIntRep(value2Ptr, &tclListType) - && (TclGetIntForIndexM(NULL, value2Ptr, objc-1, - &index) == TCL_OK)) { - TclDecrRefCount(value2Ptr); - tosPtr--; - pcAdjustment = 1; - goto lindexFastPath; + && !TclHasIntRep(value2Ptr, &tclListType)) { + int code; + + DECACHE_STACK_INFO(); + code = TclGetIntForIndexM(interp, value2Ptr, objc-1, &index); + CACHE_STACK_INFO(); + if (code == TCL_OK) { + TclDecrRefCount(value2Ptr); + tosPtr--; + pcAdjustment = 1; + goto lindexFastPath; + } + Tcl_ResetResult(interp); } objResultPtr = TclLindexList(interp, valuePtr, value2Ptr); @@ -5064,7 +5076,7 @@ TEBCresume( if (toIdx == TCL_INDEX_NONE) { emptyList: - objResultPtr = Tcl_NewObj(); + TclNewObj(objResultPtr); TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); } @@ -5298,10 +5310,13 @@ TEBCresume( */ length = Tcl_GetCharLength(valuePtr); + DECACHE_STACK_INFO(); if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { + CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } + CACHE_STACK_INFO(); if ((index < 0) || (index >= length)) { TclNewObj(objResultPtr); @@ -5321,7 +5336,7 @@ TEBCresume( * practical use. */ if (ch == -1) { - objResultPtr = Tcl_NewObj(); + TclNewObj(objResultPtr); } else { length = Tcl_UniCharToUtf(ch, buf); if ((ch >= 0xD800) && (length < 3)) { @@ -5338,13 +5353,21 @@ TEBCresume( TRACE(("\"%.20s\" %.20s %.20s =>", O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1; + + DECACHE_STACK_INFO(); if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, - &fromIdx) != TCL_OK - || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, + &fromIdx) != TCL_OK) { + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } + if (TclGetIntForIndexM(interp, OBJ_AT_TOS, length, &toIdx) != TCL_OK) { + CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } + CACHE_STACK_INFO(); if (fromIdx < 0) { fromIdx = 0; @@ -5427,14 +5450,17 @@ TEBCresume( endIdx = Tcl_GetCharLength(valuePtr) - 1; TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr))); + DECACHE_STACK_INFO(); if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, endIdx, &fromIdx) != TCL_OK || TclGetIntForIndexM(interp, OBJ_AT_TOS, endIdx, &toIdx) != TCL_OK) { + CACHE_STACK_INFO(); TclDecrRefCount(value3Ptr); TRACE_ERROR(interp); goto gotError; } + CACHE_STACK_INFO(); TclDecrRefCount(OBJ_AT_TOS); (void) POP_OBJECT(); TclDecrRefCount(OBJ_AT_TOS); @@ -6130,7 +6156,7 @@ TEBCresume( wideResultOfArithmetic: TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewWideIntObj(wResult); + TclNewIntObj(objResultPtr, wResult); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } @@ -6401,8 +6427,8 @@ TEBCresume( if (TclHasIntRep(valuePtr, &tclBooleanType)) { objResultPtr = TCONST(1); } else { - int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK); - objResultPtr = TCONST(result); + int res = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK); + objResultPtr = TCONST(res); } TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr); NEXT_INST_F(1, 0, 1); @@ -6596,7 +6622,7 @@ TEBCresume( } { ForeachInfo *infoPtr; - Tcl_Obj *listPtr, **elements, *tmpPtr; + Tcl_Obj *listPtr, **elements; ForeachVarList *varListPtr; int numLists, listLen, numVars; int listTmpDepth; @@ -7020,7 +7046,7 @@ TEBCresume( break; } if (valuePtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd)); + Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, Tcl_NewWideIntObj(opnd)); } else { TclNewIntObj(value2Ptr, opnd); Tcl_IncrRefCount(value2Ptr); @@ -7538,7 +7564,7 @@ TEBCresume( default: Tcl_Panic("clockRead instruction with unknown clock#"); } - objResultPtr = Tcl_NewWideIntObj(wval); + TclNewIntObj(objResultPtr, wval); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(2, 0, 1); } @@ -9693,7 +9719,7 @@ EvalStatsCmd( #define Percent(a,b) ((a) * 100.0 / (b)) - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); numInstructions = 0.0; diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 3babd43..f9636d8 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -904,7 +904,7 @@ FileBasename( } } if (resultPtr == NULL) { - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); } Tcl_IncrRefCount(resultPtr); Tcl_DecrRefCount(splitPtr); @@ -1085,7 +1085,7 @@ TclFileAttrsCmd( } if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, - "option", INDEX_TEMP_TABLE, &index) != TCL_OK) { + "option", TCL_INDEX_TEMP_TABLE, &index) != TCL_OK) { goto end; } if (Tcl_FSFileAttrsGet(interp, index, filePtr, @@ -1110,7 +1110,7 @@ TclFileAttrsCmd( for (i = 0; i < objc ; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, - "option", INDEX_TEMP_TABLE, &index) != TCL_OK) { + "option", TCL_INDEX_TEMP_TABLE, &index) != TCL_OK) { goto end; } if (i + 1 == objc) { diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 187003d..c3f3bf0 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -587,7 +587,8 @@ Tcl_SplitPath( * plus the argv pointers and the terminating NULL pointer. */ - *argvPtr = (const char **)ckalloc((((*argcPtr) + 1) * sizeof(char *)) + size); + *argvPtr = (const char **)ckalloc( + ((((*argcPtr) + 1) * sizeof(char *)) + size)); /* * Position p after the last argv pointer and copy the contents of the @@ -644,12 +645,13 @@ SplitUnixPath( { int length; const char *origPath = path, *elementStart; - Tcl_Obj *result = Tcl_NewObj(); + Tcl_Obj *result; /* * Deal with the root directory as a special case. */ + TclNewObj(result); if (*path == '/') { Tcl_Obj *rootElt; ++path; @@ -735,9 +737,10 @@ SplitWinPath( const char *p, *elementStart; Tcl_PathType type = TCL_PATH_ABSOLUTE; Tcl_DString buf; - Tcl_Obj *result = Tcl_NewObj(); + Tcl_Obj *result; Tcl_DStringInit(&buf); + TclNewObj(result); p = ExtractWinRoot(path, &buf, 0, &type); /* @@ -977,7 +980,7 @@ Tcl_JoinPath( Tcl_DString *resultPtr) /* Pointer to previously initialized DString */ { int i, len; - Tcl_Obj *listObj = Tcl_NewObj(); + Tcl_Obj *listObj; Tcl_Obj *resultObj; const char *resultStr; @@ -985,6 +988,7 @@ Tcl_JoinPath( * Build the list of paths. */ + TclNewObj(listObj); for (i = 0; i < argc; i++) { Tcl_ListObjAppendElement(NULL, listObj, Tcl_NewStringObj(argv[i], -1)); @@ -1234,7 +1238,7 @@ Tcl_GlobObjCmd( "-directory", "-join", "-nocomplain", "-path", "-tails", "-types", "--", NULL }; - enum options { + enum globOptionsEnum { GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS, GLOB_TYPE, GLOB_LAST }; @@ -1267,7 +1271,7 @@ Tcl_GlobObjCmd( } } - switch (index) { + switch ((enum globOptionsEnum) index) { case GLOB_NOCOMPLAIN: /* -nocomplain */ globFlags |= TCL_GLOBMODE_NO_COMPLAIN; break; @@ -1280,7 +1284,10 @@ Tcl_GlobObjCmd( } if (dir != PATH_NONE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"-directory\" cannot be used with \"-path\"", -1)); + dir == PATH_DIR + ? "\"-directory\" may only be used once" + : "\"-directory\" cannot be used with \"-path\"", + -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; @@ -1305,7 +1312,10 @@ Tcl_GlobObjCmd( } if (dir != PATH_NONE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"-path\" cannot be used with \"-directory\"", -1)); + dir == PATH_GENERAL + ? "\"-path\" may only be used once" + : "\"-path\" cannot be used with \"-dictionary\"", + -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index 33b23ae..a84d3c2 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -1002,7 +1002,7 @@ TclClockOldscanObjCmd( yyHaveRel = 0; yyRelMonth = 0; yyRelDay = 0; yyRelSeconds = 0; yyRelPointer = NULL; - dateInfo.messages = Tcl_NewObj(); + TclNewObj(dateInfo.messages); dateInfo.separatrix = ""; Tcl_IncrRefCount(dateInfo.messages); @@ -1059,8 +1059,8 @@ TclClockOldscanObjCmd( return TCL_ERROR; } - result = Tcl_NewObj(); - resultElement = Tcl_NewObj(); + TclNewObj(result); + TclNewObj(resultElement); if (yyHaveDate) { Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj((int) yyYear)); @@ -1078,7 +1078,7 @@ TclClockOldscanObjCmd( Tcl_ListObjAppendElement(interp, result, Tcl_NewObj()); } - resultElement = Tcl_NewObj(); + TclNewObj(resultElement); if (yyHaveZone) { Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj((int) -yyTimezone)); @@ -1087,7 +1087,7 @@ TclClockOldscanObjCmd( } Tcl_ListObjAppendElement(interp, result, resultElement); - resultElement = Tcl_NewObj(); + TclNewObj(resultElement); if (yyHaveRel) { Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj((int) yyRelMonth)); @@ -1098,7 +1098,7 @@ TclClockOldscanObjCmd( } Tcl_ListObjAppendElement(interp, result, resultElement); - resultElement = Tcl_NewObj(); + TcNewObj(resultElement); if (yyHaveDay && !yyHaveDate) { Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj((int) yyDayOrdinal)); @@ -1107,7 +1107,7 @@ TclClockOldscanObjCmd( } Tcl_ListObjAppendElement(interp, result, resultElement); - resultElement = Tcl_NewObj(); + TclNewObj(resultElement); if (yyHaveOrdinalMonth) { Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj((int) yyMonthOrdinal)); diff --git a/generic/tclIO.c b/generic/tclIO.c index 7af6aa0..1547489 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -287,9 +287,9 @@ static int WillRead(Channel *chanPtr); #define IsBufferOverflowing(bufPtr) ((bufPtr)->nextAdded>(bufPtr)->bufLength) -#define InsertPoint(bufPtr) ((bufPtr)->buf + (bufPtr)->nextAdded) +#define InsertPoint(bufPtr) (&(bufPtr)->buf[(bufPtr)->nextAdded]) -#define RemovePoint(bufPtr) ((bufPtr)->buf + (bufPtr)->nextRemoved) +#define RemovePoint(bufPtr) (&(bufPtr)->buf[(bufPtr)->nextRemoved]) /* * For working with channel state flag bits. @@ -11130,7 +11130,7 @@ FixLevelCode( if (0 == strcmp(TclGetString(lv[i]), "-level")) { if (newlevel >= 0) { lvn[j++] = lv[i]; - lvn[j++] = Tcl_NewIntObj(newlevel); + lvn[j++] = Tcl_NewWideIntObj(newlevel); newlevel = -1; lignore = 1; continue; @@ -11140,7 +11140,7 @@ FixLevelCode( } else if (0 == strcmp(TclGetString(lv[i]), "-code")) { if (newcode >= 0) { lvn[j++] = lv[i]; - lvn[j++] = Tcl_NewIntObj(newcode); + lvn[j++] = Tcl_NewWideIntObj(newcode); newcode = -1; cignore = 1; continue; diff --git a/generic/tclIO.h b/generic/tclIO.h index d10f268..54aa5af 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -44,7 +44,7 @@ typedef struct ChannelBuffer { int bufLength; /* How big is the buffer? */ struct ChannelBuffer *nextPtr; /* Next buffer in chain. */ - char buf[1]; /* Placeholder for real buffer. The real + char buf[TCLFLEXARRAY]; /* Placeholder for real buffer. The real * buffer occuppies this space + bufSize-1 * bytes. This must be the last field in the * structure. */ diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 508a991..e28f9de 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -314,7 +314,7 @@ Tcl_GetsObjCmd( } TclChannelPreserve(chan); - linePtr = Tcl_NewObj(); + TclNewObj(linePtr); lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen < 0) { if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { @@ -343,7 +343,7 @@ Tcl_GetsObjCmd( code = TCL_ERROR; goto done; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(lineLen)); } else { Tcl_SetObjResult(interp, linePtr); } @@ -453,7 +453,7 @@ Tcl_ReadObjCmd( } } - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); Tcl_IncrRefCount(resultPtr); TclChannelPreserve(chan); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); @@ -888,7 +888,7 @@ Tcl_ExecObjCmd( static const char *const options[] = { "-ignorestderr", "-keepnewline", "--", NULL }; - enum options { + enum execOptionsEnum { EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST }; @@ -975,7 +975,7 @@ Tcl_ExecObjCmd( return TCL_OK; } - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { if (Tcl_ReadChars(chan, resultPtr, -1, 0) == TCL_IO_FAILURE) { /* @@ -1363,7 +1363,7 @@ AcceptCallbackProc( Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj( Tcl_GetChannelName(chan), -1)); Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj(address, -1)); - Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewIntObj(port)); + Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewWideIntObj(port)); script = Tcl_ConcatObj(2, objv); Tcl_IncrRefCount(script); @@ -1470,7 +1470,7 @@ Tcl_SocketObjCmd( "-async", "-myaddr", "-myport", "-reuseaddr", "-reuseport", "-server", NULL }; - enum socketOptions { + enum socketOptionsEnum { SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT, SKT_SERVER }; @@ -1495,7 +1495,7 @@ Tcl_SocketObjCmd( TCL_EXACT, &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum socketOptions) optionIndex) { + switch ((enum socketOptionsEnum) optionIndex) { case SKT_ASYNC: if (server == 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -1806,7 +1806,7 @@ ChanPendingObjCmd( Tcl_Channel chan; int index, mode; static const char *const options[] = {"input", "output", NULL}; - enum options {PENDING_INPUT, PENDING_OUTPUT}; + enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT}; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "mode channelId"); @@ -1822,19 +1822,19 @@ ChanPendingObjCmd( return TCL_ERROR; } - switch ((enum options) index) { + switch ((enum pendingOptionsEnum) index) { case PENDING_INPUT: if (!(mode & TCL_READABLE)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1)); } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_InputBuffered(chan))); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_InputBuffered(chan))); } break; case PENDING_OUTPUT: if (!(mode & TCL_WRITABLE)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1)); } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan))); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_OutputBuffered(chan))); } break; } @@ -1954,7 +1954,7 @@ ChanPipeObjCmd( channelNames[0] = Tcl_GetChannelName(rchan); channelNames[1] = Tcl_GetChannelName(wchan); - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj(channelNames[0], -1)); Tcl_ListObjAppendElement(NULL, resultPtr, diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index c622afa..e50c96f 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -1591,7 +1591,7 @@ ReflectSeekWide( Tcl_Preserve(rcPtr); - offObj = Tcl_NewWideIntObj(offset); + TclNewIntObj(offObj, offset); baseObj = Tcl_NewStringObj( (seekMode == SEEK_SET) ? "start" : (seekMode == SEEK_CUR) ? "current" : "end", -1); @@ -3052,7 +3052,7 @@ ForwardProc( TclNewIntObj(toReadObj, paramPtr->input.toRead); Tcl_IncrRefCount(toReadObj); - Tcl_Preserve(rcPtr); + Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK){ int code = ErrnoReturn(rcPtr, resObj); @@ -3127,15 +3127,18 @@ ForwardProc( } case ForwardedSeek: { - Tcl_Obj *offObj = Tcl_NewWideIntObj(paramPtr->seek.offset); - Tcl_Obj *baseObj = Tcl_NewStringObj( - (paramPtr->seek.seekMode==SEEK_SET) ? "start" : - (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1); + Tcl_Obj *offObj; + Tcl_Obj *baseObj; - Tcl_IncrRefCount(offObj); - Tcl_IncrRefCount(baseObj); + TclNewIntObj(offObj, paramPtr->seek.offset); + baseObj = Tcl_NewStringObj( + (paramPtr->seek.seekMode==SEEK_SET) ? "start" : + (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1); - Tcl_Preserve(rcPtr); + Tcl_IncrRefCount(offObj); + Tcl_IncrRefCount(baseObj); + + Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK){ ForwardSetObjError(paramPtr, resObj); paramPtr->seek.offset = -1; diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 9a82cdb..3c5f133 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -1219,7 +1219,7 @@ ReflectInput( } if (Tcl_IsShared(bufObj)) { Tcl_DecrRefCount(bufObj); - bufObj = Tcl_NewObj(); + TclNewObj(bufObj); Tcl_IncrRefCount(bufObj); } Tcl_SetByteArrayLength(bufObj, 0); diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index f8072b6..fcce215 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1684,7 +1684,7 @@ Tcl_FSEvalFileEx( * Tilde-substitution is performed on this * pathname. */ const char *encodingName) /* Either the name of an encoding or NULL to - use the system encoding. */ + use the utf-8 encoding. */ { int length, result = TCL_ERROR; Tcl_StatBuf statBuf; @@ -1722,19 +1722,19 @@ Tcl_FSEvalFileEx( /* * If the encoding is specified, set the channel to that encoding. - * Otherwise don't touch it, leaving things up to the system encoding. If - * the encoding is unknown report an error. + * Otherwise use utf-8. If the encoding is unknown report an error. */ - if (encodingName != NULL) { - if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) - != TCL_OK) { - Tcl_Close(interp,chan); - return result; - } + if (encodingName == NULL) { + encodingName = "utf-8"; + } + if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) + != TCL_OK) { + Tcl_Close(interp,chan); + return result; } - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); /* @@ -1821,7 +1821,7 @@ TclNREvalFile( * evaluate. Tilde-substitution is performed on * this pathname. */ const char *encodingName) /* The name of an encoding to use, or NULL to - * use the system encoding. */ + * use the utf-8 encoding. */ { Tcl_StatBuf statBuf; Tcl_Obj *oldScriptFile, *objPtr; @@ -1858,19 +1858,19 @@ TclNREvalFile( /* * If the encoding is specified, set the channel to that encoding. - * Otherwise don't touch it, leaving things up to the system encoding. If - * the encoding is unknown report an error. + * Otherwise use utf-8. If the encoding is unknown report an error. */ - if (encodingName != NULL) { - if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) - != TCL_OK) { - Tcl_Close(interp,chan); - return TCL_ERROR; - } + if (encodingName == NULL) { + encodingName = "utf-8"; + } + if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) + != TCL_OK) { + Tcl_Close(interp, chan); + return TCL_ERROR; } - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); /* @@ -2697,7 +2697,7 @@ Tcl_FSGetCwd( * always be in the 'else' branch below which is simpler. */ - ClientData cd = (ClientData) Tcl_FSGetNativePath(norm); + void *cd = (void *) Tcl_FSGetNativePath(norm); FsUpdateCwd(norm, TclNativeDupInternalRep(cd)); Tcl_DecrRefCount(norm); @@ -3173,7 +3173,7 @@ Tcl_LoadFile( } if (fsPtr->loadFileProc != NULL) { - int retVal = ((Tcl_FSLoadFileProc2 *)(void *)(fsPtr->loadFileProc)) + retVal = ((Tcl_FSLoadFileProc2 *)(void *)(fsPtr->loadFileProc)) (interp, pathPtr, handlePtr, &unloadProcPtr, flags); if (retVal == TCL_OK) { @@ -3765,7 +3765,7 @@ Tcl_Obj * Tcl_FSListVolumes(void) { FilesystemRecord *fsRecPtr; - Tcl_Obj *resultPtr = Tcl_NewObj(); + Tcl_Obj *resultPtr; /* * Call each "listVolumes" function of each registered filesystem in @@ -3773,6 +3773,7 @@ Tcl_FSListVolumes(void) * has succeeded. */ + TclNewObj(resultPtr); fsRecPtr = FsGetFirstFilesystem(); Claim(); while (fsRecPtr != NULL) { @@ -3832,7 +3833,7 @@ FsListMounts( if (fsRecPtr->fsPtr != &tclNativeFilesystem && fsRecPtr->fsPtr->matchInDirectoryProc != NULL) { if (resultPtr == NULL) { - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); } fsRecPtr->fsPtr->matchInDirectoryProc(NULL, resultPtr, pathPtr, pattern, &mountsOnly); @@ -3903,7 +3904,7 @@ Tcl_FSSplitPath( * For example, 'ftp://' is a valid drive name. */ - result = Tcl_NewObj(); + TclNewObj(result); p = Tcl_GetString(pathPtr); Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(p, driveNameLength)); @@ -4488,7 +4489,7 @@ Tcl_FSGetFileSystemForPath( return NULL; } - /* Start with an up-to-date copy of the master filesystem. */ + /* Start with an up-to-date copy of the filesystem. */ fsRecPtr = FsGetFirstFilesystem(); Claim(); diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 4749e6e..6ae2075 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -114,7 +114,7 @@ Tcl_GetIndexFromObj( int flags, /* 0 or TCL_EXACT */ int *indexPtr) /* Place to store resulting integer index. */ { - if (!(flags & INDEX_TEMP_TABLE)) { + if (!(flags & TCL_INDEX_TEMP_TABLE)) { /* * See if there is a valid cached result from a previous lookup (doing the @@ -216,7 +216,7 @@ GetIndexFromObjList( tablePtr[objc] = NULL; result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, - sizeof(char *), msg, flags | INDEX_TEMP_TABLE, indexPtr); + sizeof(char *), msg, flags | TCL_INDEX_TEMP_TABLE, indexPtr); ckfree(tablePtr); @@ -280,7 +280,7 @@ Tcl_GetIndexFromObjStruct( * See if there is a valid cached result from a previous lookup. */ - if (!(flags & INDEX_TEMP_TABLE)) { + if (!(flags & TCL_INDEX_TEMP_TABLE)) { irPtr = TclFetchIntRep(objPtr, &indexType); if (irPtr) { indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; @@ -344,7 +344,7 @@ Tcl_GetIndexFromObjStruct( * operation. */ - if (!(flags & INDEX_TEMP_TABLE)) { + if (!(flags & TCL_INDEX_TEMP_TABLE)) { irPtr = TclFetchIntRep(objPtr, &indexType); if (irPtr) { indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; @@ -553,7 +553,7 @@ PrefixMatchObjCmd( static const char *const matchOptions[] = { "-error", "-exact", "-message", NULL }; - enum matchOptions { + enum matchOptionsEnum { PRFMATCH_ERROR, PRFMATCH_EXACT, PRFMATCH_MESSAGE }; @@ -567,7 +567,7 @@ PrefixMatchObjCmd( &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum matchOptions) index) { + switch ((enum matchOptionsEnum) index) { case PRFMATCH_EXACT: flags |= TCL_EXACT; break; @@ -633,7 +633,7 @@ PrefixMatchObjCmd( } Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewStringObj("-code", 5)); - Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewIntObj(result)); + Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewWideIntObj(result)); return Tcl_SetReturnOptions(interp, errorPtr); } diff --git a/generic/tclInt.h b/generic/tclInt.h index 3018d98..9dde88b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -925,6 +925,12 @@ typedef struct VarInHash { *---------------------------------------------------------------- */ +#if defined(__GNUC__) && (__GNUC__ > 2) +# define TCLFLEXARRAY 0 +#else +# define TCLFLEXARRAY 1 +#endif + /* * Forward declaration to prevent an error when the forward reference to * Command is encountered in the Proc and ImportRef types declared below. @@ -968,7 +974,7 @@ typedef struct CompiledLocal { * is marked by a unique tag during * compilation, and that same tag is used to * find the variable at runtime. */ - char name[1]; /* Name of the local variable starts here. If + char name[TCLFLEXARRAY]; /* Name of the local variable starts here. If * the name is NULL, this will just be '\0'. * The actual size of this field will be large * enough to hold the name. MUST BE THE LAST @@ -1306,7 +1312,7 @@ typedef struct CFWordBC { typedef struct ContLineLoc { int num; /* Number of entries in loc, not counting the * final -1 marker entry. */ - int loc[1]; /* Table of locations, as character offsets. + int loc[TCLFLEXARRAY];/* Table of locations, as character offsets. * The table is allocated as part of the * structure, extending behind the nominal end * of the structure. An entry containing the @@ -1455,7 +1461,7 @@ typedef struct ExecStack { Tcl_Obj **markerPtr; Tcl_Obj **endPtr; Tcl_Obj **tosPtr; - Tcl_Obj *stackWords[1]; + Tcl_Obj *stackWords[TCLFLEXARRAY]; } ExecStack; /* @@ -1707,18 +1713,18 @@ typedef struct Command { /* * Flag bits for commands. * - * CMD_IS_DELETED - Means that the command is in the process of + * CMD_DYING - If 1 the command is in the process of * being deleted (its deleteProc is currently * executing). Other attempts to delete the * command should be ignored. - * CMD_TRACE_ACTIVE - 1 means that trace processing is currently + * CMD_TRACE_ACTIVE - If 1 the trace processing is currently * underway for a rename/delete change. See the * two flags below for which is currently being * processed. - * CMD_HAS_EXEC_TRACES - 1 means that this command has at least one + * CMD_HAS_EXEC_TRACES - If 1 means that this command has at least one * execution trace (as opposed to simple * delete/rename traces) in its tracePtr list. - * CMD_COMPILES_EXPANDED - 1 means that this command has a compiler that + * CMD_COMPILES_EXPANDED - If 1 this command has a compiler that * can handle expansion (provided it is not the * first word). * TCL_TRACE_RENAME - A rename trace is in progress. Further @@ -1728,7 +1734,7 @@ typedef struct Command { * (these last two flags are defined in tcl.h) */ -#define CMD_IS_DELETED 0x01 +#define CMD_DYING 0x01 #define CMD_TRACE_ACTIVE 0x02 #define CMD_HAS_EXEC_TRACES 0x04 #define CMD_COMPILES_EXPANDED 0x08 @@ -2606,15 +2612,6 @@ typedef struct TclFileAttrProcs { } TclFileAttrProcs; /* - * Private flag value which controls Tcl_GetIndexFromObj*() routines - * to instruct them not to cache lookups because the table will not - * live long enough to make it worthwhile. Must not clash with public - * flag value TCL_EXACT. - */ - -#define INDEX_TEMP_TABLE 2 - -/* * Opaque handle used in pipeline routines to encapsulate platform-dependent * state. */ @@ -4175,7 +4172,7 @@ MODULE_SCOPE int TclFullFinalizationRequested(void); MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd; MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclLocalAliasObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclSlaveObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclChildObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInvokeImportedCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOPublicObjectCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOPrivateObjectCmd; @@ -4521,12 +4518,15 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, */ #define TclInvalidateStringRep(objPtr) \ - if ((objPtr)->bytes != NULL) { \ - if ((objPtr)->bytes != &tclEmptyString) { \ - ckfree((objPtr)->bytes); \ + do { \ + Tcl_Obj *_isobjPtr = (Tcl_Obj *)(objPtr); \ + if (_isobjPtr->bytes != NULL) { \ + if (_isobjPtr->bytes != &tclEmptyString) { \ + ckfree((char *)_isobjPtr->bytes); \ + } \ + _isobjPtr->bytes = NULL; \ } \ - (objPtr)->bytes = NULL; \ - } + } while (0) /* * These form part of the native filesystem support. They are needed here @@ -4553,7 +4553,8 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; *---------------------------------------------------------------- */ -#define TclHasStringRep(objPtr) ((objPtr)->bytes != NULL) +#define TclHasStringRep(objPtr) \ + ((objPtr)->bytes != NULL) /* *---------------------------------------------------------------- @@ -4935,7 +4936,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; * Computes number of bytes from beginning of structure to a given field. */ -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && !defined(BUILD_tcl) # define TclOffset(type, field) ((int) offsetof(type, field)) #endif /* Workaround for platforms missing offsetof(), e.g. VC++ 6.0 */ @@ -4960,10 +4961,30 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; * the internal stubs, but the core can use the macro instead. */ -#define TclCleanupCommandMacro(cmdPtr) \ - if ((cmdPtr)->refCount-- <= 1) { \ - ckfree(cmdPtr);\ - } +#define TclCleanupCommandMacro(cmdPtr) \ + do { \ + if ((cmdPtr)->refCount-- <= 1) { \ + ckfree(cmdPtr); \ + } \ + } while (0) + + +/* + * inside this routine crement refCount first incase cmdPtr is replacing itself + */ +#define TclRoutineAssign(location, cmdPtr) \ + do { \ + (cmdPtr)->refCount++; \ + if ((location) != NULL \ + && (location--) <= 1) { \ + ckfree(((location))); \ + } \ + (location) = (cmdPtr); \ + } while (0) + + +#define TclRoutineHasName(cmdPtr) \ + ((cmdPtr)->hPtr != NULL) /* *---------------------------------------------------------------- diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 669baae..de308de 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -602,7 +602,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; # endif /* TCL_NO_DEPRECATED */ #else # undef TclpGetPid -# define TclpGetPid(pid) ((unsigned long) (pid)) +# define TclpGetPid(pid) ((int)(size_t)(pid)) #endif #endif /* _TCLINTPLATDECLS */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index de8cd32..f724175 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -27,34 +27,34 @@ struct Target; /* * struct Alias: * - * Stores information about an alias. Is stored in the slave interpreter and - * used by the source command to find the target command in the master when + * Stores information about an alias. Is stored in the child interpreter and + * used by the source command to find the target command in the parent when * the source command is invoked. */ typedef struct Alias { - Tcl_Obj *token; /* Token for the alias command in the slave + Tcl_Obj *token; /* Token for the alias command in the child * interp. This used to be the command name in - * the slave when the alias was first + * the child when the alias was first * created. */ Tcl_Interp *targetInterp; /* Interp in which target command will be * invoked. */ - Tcl_Command slaveCmd; /* Source command in slave interpreter, bound + Tcl_Command childCmd; /* Source command in child interpreter, bound * to command that invokes the target command * in the target interpreter. */ Tcl_HashEntry *aliasEntryPtr; - /* Entry for the alias hash table in slave. + /* Entry for the alias hash table in child. * This is used by alias deletion to remove - * the alias from the slave interpreter alias + * the alias from the child interpreter alias * table. */ - struct Target *targetPtr; /* Entry for target command in master. This is - * used in the master interpreter to map back + struct Target *targetPtr; /* Entry for target command in parent. This is + * used in the parent interpreter to map back * from the target command to aliases * redirecting to it. */ int objc; /* Count of Tcl_Obj in the prefix of the * target command to be invoked in the target * interpreter. Additional arguments specified - * when calling the alias in the slave interp + * when calling the alias in the child interp * will be appended to the prefix before the * command is invoked. */ Tcl_Obj *objPtr; /* The first actual prefix object - the target @@ -66,45 +66,45 @@ typedef struct Alias { /* * - * struct Slave: + * struct Child: * - * Used by the "interp" command to record and find information about slave - * interpreters. Maps from a command name in the master to information about a - * slave interpreter, e.g. what aliases are defined in it. + * Used by the "interp" command to record and find information about child + * interpreters. Maps from a command name in the parent to information about a + * child interpreter, e.g. what aliases are defined in it. */ -typedef struct Slave { - Tcl_Interp *masterInterp; /* Master interpreter for this slave. */ - Tcl_HashEntry *slaveEntryPtr; - /* Hash entry in masters slave table for this - * slave interpreter. Used to find this - * record, and used when deleting the slave - * interpreter to delete it from the master's +typedef struct Child { + Tcl_Interp *parentInterp; /* Parent interpreter for this child. */ + Tcl_HashEntry *childEntryPtr; + /* Hash entry in parents child table for this + * child interpreter. Used to find this + * record, and used when deleting the child + * interpreter to delete it from the parent's * table. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ + Tcl_Interp *childInterp; /* The child interpreter. */ Tcl_Command interpCmd; /* Interpreter object command. */ Tcl_HashTable aliasTable; /* Table which maps from names of commands in - * slave interpreter to struct Alias defined + * child interpreter to struct Alias defined * below. */ -} Slave; +} Child; /* * struct Target: * - * Maps from master interpreter commands back to the source commands in slave + * Maps from parent interpreter commands back to the source commands in child * interpreters. This is needed because aliases can be created between sibling * interpreters and must be deleted when the target interpreter is deleted. In * case they would not be deleted the source interpreter would be left with a - * "dangling pointer". One such record is stored in the Master record of the - * master interpreter with the master for each alias which directs to a - * command in the master. These records are used to remove the source command - * for an from a slave if/when the master is deleted. They are organized in a - * doubly-linked list attached to the master interpreter. + * "dangling pointer". One such record is stored in the Parent record of the + * parent interpreter with the parent for each alias which directs to a + * command in the parent. These records are used to remove the source command + * for an from a child if/when the parent is deleted. They are organized in a + * doubly-linked list attached to the parent interpreter. */ typedef struct Target { - Tcl_Command slaveCmd; /* Command for alias in slave interp. */ - Tcl_Interp *slaveInterp; /* Slave Interpreter. */ + Tcl_Command childCmd; /* Command for alias in child interp. */ + Tcl_Interp *childInterp; /* Child Interpreter. */ struct Target *nextPtr; /* Next in list of target records, or NULL if * at the end of the list of targets. */ struct Target *prevPtr; /* Previous in list of target records, or NULL @@ -112,43 +112,43 @@ typedef struct Target { } Target; /* - * struct Master: + * struct Parent: * - * This record is used for two purposes: First, slaveTable (a hashtable) maps - * from names of commands to slave interpreters. This hashtable is used to - * store information about slave interpreters of this interpreter, to map over - * all slaves, etc. The second purpose is to store information about all - * aliases in slaves (or siblings) which direct to target commands in this + * This record is used for two purposes: First, childTable (a hashtable) maps + * from names of commands to child interpreters. This hashtable is used to + * store information about child interpreters of this interpreter, to map over + * all children, etc. The second purpose is to store information about all + * aliases in children (or siblings) which direct to target commands in this * interpreter (using the targetsPtr doubly-linked list). * * NB: the flags field in the interp structure, used with SAFE_INTERP mask * denotes whether the interpreter is safe or not. Safe interpreters have - * restricted functionality, can only create safe slave interpreters and can + * restricted functionality, can only create safe interpreters and can * only load safe extensions. */ -typedef struct Master { - Tcl_HashTable slaveTable; /* Hash table for slave interpreters. Maps - * from command names to Slave records. */ +typedef struct Parent { + Tcl_HashTable childTable; /* Hash table for child interpreters. Maps + * from command names to Child records. */ Target *targetsPtr; /* The head of a doubly-linked list of all the * target records which denote aliases from - * slaves or sibling interpreters that direct + * children or sibling interpreters that direct * to commands in this interpreter. This list * is used to remove dangling pointers from - * the slave (or sibling) interpreters when + * the child (or sibling) interpreters when * this interpreter is deleted. */ -} Master; +} Parent; /* - * The following structure keeps track of all the Master and Slave information + * The following structure keeps track of all the Parent and Child information * on a per-interp basis. */ typedef struct InterpInfo { - Master master; /* Keeps track of all interps for which this - * interp is the Master. */ - Slave slave; /* Information necessary for this interp to - * function as a slave. */ + Parent parent; /* Keeps track of all interps for which this + * interp is the Parent. */ + Child child; /* Information necessary for this interp to + * function as a child. */ } InterpInfo; /* @@ -214,55 +214,55 @@ struct LimitHandler { */ static int AliasCreate(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp, + Tcl_Interp *childInterp, Tcl_Interp *parentInterp, Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc, Tcl_Obj *const objv[]); static int AliasDelete(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Tcl_Obj *namePtr); + Tcl_Interp *childInterp, Tcl_Obj *namePtr); static int AliasDescribe(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Tcl_Obj *objPtr); -static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp); + Tcl_Interp *childInterp, Tcl_Obj *objPtr); +static int AliasList(Tcl_Interp *interp, Tcl_Interp *childInterp); static Tcl_ObjCmdProc AliasNRCmd; static Tcl_CmdDeleteProc AliasObjCmdDeleteProc; static Tcl_Interp * GetInterp(Tcl_Interp *interp, Tcl_Obj *pathPtr); static Tcl_Interp * GetInterp2(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static Tcl_InterpDeleteProc InterpInfoDeleteProc; -static int SlaveBgerror(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, int objc, +static int ChildBgerror(Tcl_Interp *interp, + Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); -static Tcl_Interp * SlaveCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr, +static Tcl_Interp * ChildCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr, int safe); -static int SlaveDebugCmd(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, +static int ChildDebugCmd(Tcl_Interp *interp, + Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); -static int SlaveEval(Tcl_Interp *interp, Tcl_Interp *slaveInterp, +static int ChildEval(Tcl_Interp *interp, Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); -static int SlaveExpose(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, int objc, +static int ChildExpose(Tcl_Interp *interp, + Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); -static int SlaveHide(Tcl_Interp *interp, Tcl_Interp *slaveInterp, +static int ChildHide(Tcl_Interp *interp, Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); -static int SlaveHidden(Tcl_Interp *interp, - Tcl_Interp *slaveInterp); -static int SlaveInvokeHidden(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, +static int ChildHidden(Tcl_Interp *interp, + Tcl_Interp *childInterp); +static int ChildInvokeHidden(Tcl_Interp *interp, + Tcl_Interp *childInterp, const char *namespaceName, int objc, Tcl_Obj *const objv[]); -static int SlaveMarkTrusted(Tcl_Interp *interp, - Tcl_Interp *slaveInterp); -static Tcl_CmdDeleteProc SlaveObjCmdDeleteProc; -static int SlaveRecursionLimit(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, int objc, +static int ChildMarkTrusted(Tcl_Interp *interp, + Tcl_Interp *childInterp); +static Tcl_CmdDeleteProc ChildObjCmdDeleteProc; +static int ChildRecursionLimit(Tcl_Interp *interp, + Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); -static int SlaveCommandLimitCmd(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, int consumedObjc, +static int ChildCommandLimitCmd(Tcl_Interp *interp, + Tcl_Interp *childInterp, int consumedObjc, int objc, Tcl_Obj *const objv[]); -static int SlaveTimeLimitCmd(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, int consumedObjc, +static int ChildTimeLimitCmd(Tcl_Interp *interp, + Tcl_Interp *childInterp, int consumedObjc, int objc, Tcl_Obj *const objv[]); -static void InheritLimitsFromMaster(Tcl_Interp *slaveInterp, - Tcl_Interp *masterInterp); +static void InheritLimitsFromParent(Tcl_Interp *childInterp, + Tcl_Interp *parentInterp); static void SetScriptLimitCallback(Tcl_Interp *interp, int type, Tcl_Interp *targetInterp, Tcl_Obj *scriptObj); static void CallScriptLimitCallback(ClientData clientData, @@ -275,7 +275,7 @@ static void TimeLimitCallback(ClientData clientData); /* NRE enabling */ static Tcl_NRPostProc NRPostInvokeHidden; static Tcl_ObjCmdProc NRInterpCmd; -static Tcl_ObjCmdProc NRSlaveCmd; +static Tcl_ObjCmdProc NRChildCmd; /* @@ -461,7 +461,7 @@ end: * * TclInterpInit -- * - * Initializes the invoking interpreter for using the master, slave and + * Initializes the invoking interpreter for using the parent, child and * safe interp facilities. This is called from inside Tcl_CreateInterp(). * * Results: @@ -479,22 +479,22 @@ TclInterpInit( Tcl_Interp *interp) /* Interpreter to initialize. */ { InterpInfo *interpInfoPtr; - Master *masterPtr; - Slave *slavePtr; + Parent *parentPtr; + Child *childPtr; interpInfoPtr = (InterpInfo *)ckalloc(sizeof(InterpInfo)); ((Interp *) interp)->interpInfo = interpInfoPtr; - masterPtr = &interpInfoPtr->master; - Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS); - masterPtr->targetsPtr = NULL; + parentPtr = &interpInfoPtr->parent; + Tcl_InitHashTable(&parentPtr->childTable, TCL_STRING_KEYS); + parentPtr->targetsPtr = NULL; - slavePtr = &interpInfoPtr->slave; - slavePtr->masterInterp = NULL; - slavePtr->slaveEntryPtr = NULL; - slavePtr->slaveInterp = interp; - slavePtr->interpCmd = NULL; - Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); + childPtr = &interpInfoPtr->child; + childPtr->parentInterp = NULL; + childPtr->childEntryPtr = NULL; + childPtr->childInterp = interp; + childPtr->interpCmd = NULL; + Tcl_InitHashTable(&childPtr->aliasTable, TCL_STRING_KEYS); Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd, NULL, NULL); @@ -509,7 +509,7 @@ TclInterpInit( * InterpInfoDeleteProc -- * * Invoked when an interpreter is being deleted. It releases all storage - * used by the master/slave/safe interpreter facilities. + * used by the parent/child/safe interpreter facilities. * * Results: * None. @@ -522,13 +522,13 @@ TclInterpInit( static void InterpInfoDeleteProc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp) /* Interp being deleted. All commands for - * slave interps should already be deleted. */ + * child interps should already be deleted. */ { InterpInfo *interpInfoPtr; - Slave *slavePtr; - Master *masterPtr; + Child *childPtr; + Parent *parentPtr; Target *targetPtr; interpInfoPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; @@ -537,11 +537,11 @@ InterpInfoDeleteProc( * There shouldn't be any commands left. */ - masterPtr = &interpInfoPtr->master; - if (masterPtr->slaveTable.numEntries != 0) { + parentPtr = &interpInfoPtr->parent; + if (parentPtr->childTable.numEntries != 0) { Tcl_Panic("InterpInfoDeleteProc: still exist commands"); } - Tcl_DeleteHashTable(&masterPtr->slaveTable); + Tcl_DeleteHashTable(&parentPtr->childTable); /* * Tell any interps that have aliases to this interp that they should @@ -549,35 +549,35 @@ InterpInfoDeleteProc( * have removed the target record already. */ - for (targetPtr = masterPtr->targetsPtr; targetPtr != NULL; ) { + for (targetPtr = parentPtr->targetsPtr; targetPtr != NULL; ) { Target *tmpPtr = targetPtr->nextPtr; - Tcl_DeleteCommandFromToken(targetPtr->slaveInterp, - targetPtr->slaveCmd); + Tcl_DeleteCommandFromToken(targetPtr->childInterp, + targetPtr->childCmd); targetPtr = tmpPtr; } - slavePtr = &interpInfoPtr->slave; - if (slavePtr->interpCmd != NULL) { + childPtr = &interpInfoPtr->child; + if (childPtr->interpCmd != NULL) { /* * Tcl_DeleteInterp() was called on this interpreter, rather "interp - * delete" or the equivalent deletion of the command in the master. + * delete" or the equivalent deletion of the command in the parent. * First ensure that the cleanup callback doesn't try to delete the * interp again. */ - slavePtr->slaveInterp = NULL; - Tcl_DeleteCommandFromToken(slavePtr->masterInterp, - slavePtr->interpCmd); + childPtr->childInterp = NULL; + Tcl_DeleteCommandFromToken(childPtr->parentInterp, + childPtr->interpCmd); } /* * There shouldn't be any aliases left. */ - if (slavePtr->aliasTable.numEntries != 0) { + if (childPtr->aliasTable.numEntries != 0) { Tcl_Panic("InterpInfoDeleteProc: still exist aliases"); } - Tcl_DeleteHashTable(&slavePtr->aliasTable); + Tcl_DeleteHashTable(&childPtr->aliasTable); ckfree(interpInfoPtr); } @@ -611,93 +611,104 @@ Tcl_InterpObjCmd( static int NRInterpCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Interp *slaveInterp; + Tcl_Interp *childInterp; int index; static const char *const options[] = { "alias", "aliases", "bgerror", "cancel", - "create", "debug", "delete", + "children", "create", "debug", "delete", + "eval", "exists", "expose", "hide", + "hidden", "issafe", "invokehidden", + "limit", "marktrusted", "recursionlimit", + "share", "slaves", "target", "transfer", + NULL + }; + static const char *const optionsNoSlaves[] = { + "alias", "aliases", "bgerror", "cancel", + "children", "create", "debug", "delete", "eval", "exists", "expose", "hide", "hidden", "issafe", "invokehidden", "limit", "marktrusted", "recursionlimit", - "slaves", "share", "target", "transfer", - NULL + "share", "target", "transfer", NULL }; - enum option { + enum interpOptionEnum { OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL, - OPT_CREATE, OPT_DEBUG, OPT_DELETE, - OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, - OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, - OPT_INVOKEHID, OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, - OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER + OPT_CHILDREN, OPT_CREATE, OPT_DEBUG, OPT_DELETE, + OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE, + OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, + OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, + OPT_SHARE, OPT_SLAVES, OPT_TARGET, OPT_TRANSFER }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObj(NULL, objv[1], options, + "option", 0, &index) != TCL_OK) { + /* Don't report the "slaves" option as possibility */ + Tcl_GetIndexFromObj(interp, objv[1], optionsNoSlaves, + "option", 0, &index); return TCL_ERROR; } - switch ((enum option) index) { + switch ((enum interpOptionEnum)index) { case OPT_ALIAS: { - Tcl_Interp *masterInterp; + Tcl_Interp *parentInterp; if (objc < 4) { aliasArgs: Tcl_WrongNumArgs(interp, 2, objv, - "slavePath slaveCmd ?masterPath masterCmd? ?arg ...?"); + "childPath childCmd ?parentPath parentCmd? ?arg ...?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } if (objc == 4) { - return AliasDescribe(interp, slaveInterp, objv[3]); + return AliasDescribe(interp, childInterp, objv[3]); } if ((objc == 5) && (TclGetString(objv[4])[0] == '\0')) { - return AliasDelete(interp, slaveInterp, objv[3]); + return AliasDelete(interp, childInterp, objv[3]); } if (objc > 5) { - masterInterp = GetInterp(interp, objv[4]); - if (masterInterp == NULL) { + parentInterp = GetInterp(interp, objv[4]); + if (parentInterp == NULL) { return TCL_ERROR; } - return AliasCreate(interp, slaveInterp, masterInterp, objv[3], + return AliasCreate(interp, childInterp, parentInterp, objv[3], objv[5], objc - 6, objv + 6); } goto aliasArgs; } case OPT_ALIASES: - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { + childInterp = GetInterp2(interp, objc, objv); + if (childInterp == NULL) { return TCL_ERROR; } - return AliasList(interp, slaveInterp); + return AliasList(interp, childInterp); case OPT_BGERROR: if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3); + return ChildBgerror(interp, childInterp, objc - 3, objv + 3); case OPT_CANCEL: { int i, flags; Tcl_Obj *resultObjPtr; static const char *const cancelOptions[] = { "-unwind", "--", NULL }; - enum option { + enum optionCancelEnum { OPT_UNWIND, OPT_LAST }; @@ -712,7 +723,7 @@ NRInterpCmd( return TCL_ERROR; } - switch ((enum option) index) { + switch ((enum optionCancelEnum) index) { case OPT_UNWIND: /* * The evaluation stack in the target interp is to be unwound. @@ -734,18 +745,18 @@ NRInterpCmd( } /* - * Did they specify a slave interp to cancel the script in progress + * Did they specify a child interp to cancel the script in progress * in? If not, use the current interp. */ if (i < objc) { - slaveInterp = GetInterp(interp, objv[i]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[i]); + if (childInterp == NULL) { return TCL_ERROR; } i++; } else { - slaveInterp = interp; + childInterp = interp; } if (i < objc) { @@ -761,11 +772,11 @@ NRInterpCmd( resultObjPtr = NULL; } - return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags); + return Tcl_CancelEval(childInterp, resultObjPtr, 0, flags); } case OPT_CREATE: { int i, last, safe; - Tcl_Obj *slavePtr; + Tcl_Obj *childPtr; char buf[16 + TCL_INTEGER_SPACE]; static const char *const createOptions[] = { "-safe", "--", NULL @@ -780,7 +791,7 @@ NRInterpCmd( * Weird historical rules: "-safe" is accepted at the end, too. */ - slavePtr = NULL; + childPtr = NULL; last = 0; for (i = 2; i < objc; i++) { if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { @@ -795,21 +806,21 @@ NRInterpCmd( i++; last = 1; } - if (slavePtr != NULL) { + if (childPtr != NULL) { Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?"); return TCL_ERROR; } if (i < objc) { - slavePtr = objv[i]; + childPtr = objv[i]; } } buf[0] = '\0'; - if (slavePtr == NULL) { + if (childPtr == NULL) { /* * Create an anonymous interpreter -- we choose its name and the * name of the command. We check that the command name that we use * for the interpreter does not collide with an existing command - * in the master interpreter. + * in the parent interpreter. */ for (i = 0; ; i++) { @@ -820,15 +831,15 @@ NRInterpCmd( break; } } - slavePtr = Tcl_NewStringObj(buf, -1); + childPtr = Tcl_NewStringObj(buf, -1); } - if (SlaveCreate(interp, slavePtr, safe) == NULL) { + if (ChildCreate(interp, childPtr, safe) == NULL) { if (buf[0] != '\0') { - Tcl_DecrRefCount(slavePtr); + Tcl_DecrRefCount(childPtr); } return TCL_ERROR; } - Tcl_SetObjResult(interp, slavePtr); + Tcl_SetObjResult(interp, childPtr); return TCL_OK; } case OPT_DEBUG: /* TIP #378 */ @@ -840,29 +851,29 @@ NRInterpCmd( Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveDebugCmd(interp, slaveInterp, objc - 3, objv + 3); + return ChildDebugCmd(interp, childInterp, objc - 3, objv + 3); case OPT_DELETE: { int i; InterpInfo *iiPtr; for (i = 2; i < objc; i++) { - slaveInterp = GetInterp(interp, objv[i]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[i]); + if (childInterp == NULL) { return TCL_ERROR; - } else if (slaveInterp == interp) { + } else if (childInterp == interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot delete the current interpreter", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "DELETESELF", NULL); return TCL_ERROR; } - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; - Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp, - iiPtr->slave.interpCmd); + iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo; + Tcl_DeleteCommandFromToken(iiPtr->child.parentInterp, + iiPtr->child.interpCmd); } return TCL_OK; } @@ -871,16 +882,16 @@ NRInterpCmd( Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); + return ChildEval(interp, childInterp, objc - 3, objv + 3); case OPT_EXISTS: { int exists = 1; - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { + childInterp = GetInterp2(interp, objc, objv); + if (childInterp == NULL) { if (objc > 3) { return TCL_ERROR; } @@ -895,33 +906,33 @@ NRInterpCmd( Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); + return ChildExpose(interp, childInterp, objc - 3, objv + 3); case OPT_HIDE: if ((objc < 4) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); + return ChildHide(interp, childInterp, objc - 3, objv + 3); case OPT_HIDDEN: - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { + childInterp = GetInterp2(interp, objc, objv); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveHidden(interp, slaveInterp); + return ChildHidden(interp, childInterp); case OPT_ISSAFE: - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { + childInterp = GetInterp2(interp, objc, objv); + if (childInterp == NULL) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(childInterp))); return TCL_OK; case OPT_INVOKEHID: { int i; @@ -960,11 +971,11 @@ NRInterpCmd( "path ?-namespace ns? ?-global? ?--? cmd ?arg ..?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc - i, + return ChildInvokeHidden(interp, childInterp, namespaceName, objc - i, objv + i); } case OPT_LIMIT: { @@ -981,8 +992,8 @@ NRInterpCmd( "path limitType ?-option value ...?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", 0, @@ -991,9 +1002,9 @@ NRInterpCmd( } switch ((enum LimitTypes) limitType) { case LIMIT_TYPE_COMMANDS: - return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv); + return ChildCommandLimitCmd(interp, childInterp, 4, objc,objv); case LIMIT_TYPE_TIME: - return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); + return ChildTimeLimitCmd(interp, childInterp, 4, objc, objv); } } break; @@ -1002,21 +1013,22 @@ NRInterpCmd( Tcl_WrongNumArgs(interp, 2, objv, "path"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveMarkTrusted(interp, slaveInterp); + return ChildMarkTrusted(interp, childInterp); case OPT_RECLIMIT: if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } - return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); + return ChildRecursionLimit(interp, childInterp, objc - 3, objv + 3); + case OPT_CHILDREN: case OPT_SLAVES: { InterpInfo *iiPtr; Tcl_Obj *resultPtr; @@ -1024,15 +1036,15 @@ NRInterpCmd( Tcl_HashSearch hashSearch; char *string; - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { + childInterp = GetInterp2(interp, objc, objv); + if (childInterp == NULL) { return TCL_ERROR; } - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; - resultPtr = Tcl_NewObj(); - hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch); + iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo; + TclNewObj(resultPtr); + hPtr = Tcl_FirstHashEntry(&iiPtr->parent.childTable, &hashSearch); for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { - string = (char *)Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr); + string = (char *)Tcl_GetHashKey(&iiPtr->parent.childTable, hPtr); Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj(string, -1)); } @@ -1041,35 +1053,35 @@ NRInterpCmd( } case OPT_TRANSFER: case OPT_SHARE: { - Tcl_Interp *masterInterp; /* The master of the slave. */ + Tcl_Interp *parentInterp; /* The parent of the child. */ Tcl_Channel chan; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); return TCL_ERROR; } - masterInterp = GetInterp(interp, objv[2]); - if (masterInterp == NULL) { + parentInterp = GetInterp(interp, objv[2]); + if (parentInterp == NULL) { return TCL_ERROR; } - chan = Tcl_GetChannel(masterInterp, TclGetString(objv[3]), NULL); + chan = Tcl_GetChannel(parentInterp, TclGetString(objv[3]), NULL); if (chan == NULL) { - Tcl_TransferResult(masterInterp, TCL_OK, interp); + Tcl_TransferResult(parentInterp, TCL_OK, interp); return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[4]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[4]); + if (childInterp == NULL) { return TCL_ERROR; } - Tcl_RegisterChannel(slaveInterp, chan); + Tcl_RegisterChannel(childInterp, chan); if (index == OPT_TRANSFER) { /* * When transferring, as opposed to sharing, we must unhitch the * channel from the interpreter where it started. */ - if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { - Tcl_TransferResult(masterInterp, TCL_OK, interp); + if (Tcl_UnregisterChannel(parentInterp, chan) != TCL_OK) { + Tcl_TransferResult(parentInterp, TCL_OK, interp); return TCL_ERROR; } } @@ -1086,15 +1098,15 @@ NRInterpCmd( return TCL_ERROR; } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { + childInterp = GetInterp(interp, objv[2]); + if (childInterp == NULL) { return TCL_ERROR; } aliasName = TclGetString(objv[3]); - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; - hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); + iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo; + hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" in path \"%s\" not found", @@ -1167,46 +1179,46 @@ GetInterp2( * A standard Tcl result. * * Side effects: - * Creates a new alias, manipulates the result field of slaveInterp. + * Creates a new alias, manipulates the result field of childInterp. * *---------------------------------------------------------------------- */ int Tcl_CreateAlias( - Tcl_Interp *slaveInterp, /* Interpreter for source command. */ - const char *slaveCmd, /* Command to install in slave. */ + Tcl_Interp *childInterp, /* Interpreter for source command. */ + const char *childCmd, /* Command to install in child. */ Tcl_Interp *targetInterp, /* Interpreter for target command. */ const char *targetCmd, /* Name of target command. */ int argc, /* How many additional arguments? */ const char *const *argv) /* These are the additional args. */ { - Tcl_Obj *slaveObjPtr, *targetObjPtr; + Tcl_Obj *childObjPtr, *targetObjPtr; Tcl_Obj **objv; int i; int result; - objv = (Tcl_Obj **)TclStackAlloc(slaveInterp, sizeof(Tcl_Obj *) * argc); + objv = (Tcl_Obj **)TclStackAlloc(childInterp, sizeof(Tcl_Obj *) * argc); for (i = 0; i < argc; i++) { objv[i] = Tcl_NewStringObj(argv[i], -1); Tcl_IncrRefCount(objv[i]); } - slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); - Tcl_IncrRefCount(slaveObjPtr); + childObjPtr = Tcl_NewStringObj(childCmd, -1); + Tcl_IncrRefCount(childObjPtr); targetObjPtr = Tcl_NewStringObj(targetCmd, -1); Tcl_IncrRefCount(targetObjPtr); - result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr, + result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr, targetObjPtr, argc, objv); for (i = 0; i < argc; i++) { Tcl_DecrRefCount(objv[i]); } - TclStackFree(slaveInterp, objv); + TclStackFree(childInterp, objv); Tcl_DecrRefCount(targetObjPtr); - Tcl_DecrRefCount(slaveObjPtr); + Tcl_DecrRefCount(childObjPtr); return result; } @@ -1229,26 +1241,26 @@ Tcl_CreateAlias( int Tcl_CreateAliasObj( - Tcl_Interp *slaveInterp, /* Interpreter for source command. */ - const char *slaveCmd, /* Command to install in slave. */ + Tcl_Interp *childInterp, /* Interpreter for source command. */ + const char *childCmd, /* Command to install in child. */ Tcl_Interp *targetInterp, /* Interpreter for target command. */ const char *targetCmd, /* Name of target command. */ int objc, /* How many additional arguments? */ Tcl_Obj *const objv[]) /* Argument vector. */ { - Tcl_Obj *slaveObjPtr, *targetObjPtr; + Tcl_Obj *childObjPtr, *targetObjPtr; int result; - slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); - Tcl_IncrRefCount(slaveObjPtr); + childObjPtr = Tcl_NewStringObj(childCmd, -1); + Tcl_IncrRefCount(childObjPtr); targetObjPtr = Tcl_NewStringObj(targetCmd, -1); Tcl_IncrRefCount(targetObjPtr); - result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr, + result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr, targetObjPtr, objc, objv); - Tcl_DecrRefCount(slaveObjPtr); + Tcl_DecrRefCount(childObjPtr); Tcl_DecrRefCount(targetObjPtr); return result; } @@ -1285,7 +1297,7 @@ Tcl_GetAlias( int i, objc; Tcl_Obj **objv; - hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); + hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" not found", aliasName)); @@ -1347,7 +1359,7 @@ Tcl_GetAliasObj( int objc; Tcl_Obj **objv; - hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); + hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" not found", aliasName)); @@ -1435,7 +1447,7 @@ TclPreventAliasLoop( if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) { /* - * The slave interpreter can be deleted while creating the alias. + * The child interpreter can be deleted while creating the alias. * [Bug #641195] */ @@ -1488,7 +1500,7 @@ TclPreventAliasLoop( * * Side effects: * An alias command is created and entered into the alias table for the - * slave interpreter. + * child interpreter. * *---------------------------------------------------------------------- */ @@ -1496,9 +1508,9 @@ TclPreventAliasLoop( static int AliasCreate( Tcl_Interp *interp, /* Interp for error reporting. */ - Tcl_Interp *slaveInterp, /* Interp where alias cmd will live or from + Tcl_Interp *childInterp, /* Interp where alias cmd will live or from * which alias will be deleted. */ - Tcl_Interp *masterInterp, /* Interp in which target command will be + Tcl_Interp *parentInterp, /* Interp in which target command will be * invoked. */ Tcl_Obj *namePtr, /* Name of alias cmd. */ Tcl_Obj *targetNamePtr, /* Name of target cmd. */ @@ -1508,15 +1520,15 @@ AliasCreate( Alias *aliasPtr; Tcl_HashEntry *hPtr; Target *targetPtr; - Slave *slavePtr; - Master *masterPtr; + Child *childPtr; + Parent *parentPtr; Tcl_Obj **prefv; int isNew, i; aliasPtr = (Alias *)ckalloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *)); aliasPtr->token = namePtr; Tcl_IncrRefCount(aliasPtr->token); - aliasPtr->targetInterp = masterInterp; + aliasPtr->targetInterp = parentInterp; aliasPtr->objc = objc + 1; prefv = &aliasPtr->objPtr; @@ -1528,21 +1540,21 @@ AliasCreate( Tcl_IncrRefCount(objv[i]); } - Tcl_Preserve(slaveInterp); - Tcl_Preserve(masterInterp); + Tcl_Preserve(childInterp); + Tcl_Preserve(parentInterp); - if (slaveInterp == masterInterp) { - aliasPtr->slaveCmd = Tcl_NRCreateCommand(slaveInterp, + if (childInterp == parentInterp) { + aliasPtr->childCmd = Tcl_NRCreateCommand(childInterp, TclGetString(namePtr), TclLocalAliasObjCmd, AliasNRCmd, aliasPtr, AliasObjCmdDeleteProc); } else { - aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, + aliasPtr->childCmd = Tcl_CreateObjCommand(childInterp, TclGetString(namePtr), TclAliasObjCmd, aliasPtr, AliasObjCmdDeleteProc); } - if (TclPreventAliasLoop(interp, slaveInterp, - aliasPtr->slaveCmd) != TCL_OK) { + if (TclPreventAliasLoop(interp, childInterp, + aliasPtr->childCmd) != TCL_OK) { /* * Found an alias loop! The last call to Tcl_CreateObjCommand made the * alias point to itself. Delete the command and its alias record. Be @@ -1558,11 +1570,11 @@ AliasCreate( Tcl_DecrRefCount(objv[i]); } - cmdPtr = (Command *) aliasPtr->slaveCmd; + cmdPtr = (Command *) aliasPtr->childCmd; cmdPtr->clientData = NULL; cmdPtr->deleteProc = NULL; cmdPtr->deleteData = NULL; - Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); + Tcl_DeleteCommandFromToken(childInterp, aliasPtr->childCmd); ckfree(aliasPtr); @@ -1570,8 +1582,8 @@ AliasCreate( * The result was already set by TclPreventAliasLoop. */ - Tcl_Release(slaveInterp); - Tcl_Release(masterInterp); + Tcl_Release(childInterp); + Tcl_Release(parentInterp); return TCL_ERROR; } @@ -1579,13 +1591,13 @@ AliasCreate( * Make an entry in the alias table. If it already exists, retry. */ - slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; + childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; while (1) { Tcl_Obj *newToken; const char *string; string = TclGetString(aliasPtr->token); - hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &isNew); + hPtr = Tcl_CreateHashEntry(&childPtr->aliasTable, string, &isNew); if (isNew != 0) { break; } @@ -1622,22 +1634,22 @@ AliasCreate( */ targetPtr = (Target *)ckalloc(sizeof(Target)); - targetPtr->slaveCmd = aliasPtr->slaveCmd; - targetPtr->slaveInterp = slaveInterp; + targetPtr->childCmd = aliasPtr->childCmd; + targetPtr->childInterp = childInterp; - masterPtr = &((InterpInfo*) ((Interp*) masterInterp)->interpInfo)->master; - targetPtr->nextPtr = masterPtr->targetsPtr; + parentPtr = &((InterpInfo*) ((Interp*) parentInterp)->interpInfo)->parent; + targetPtr->nextPtr = parentPtr->targetsPtr; targetPtr->prevPtr = NULL; - if (masterPtr->targetsPtr != NULL) { - masterPtr->targetsPtr->prevPtr = targetPtr; + if (parentPtr->targetsPtr != NULL) { + parentPtr->targetsPtr->prevPtr = targetPtr; } - masterPtr->targetsPtr = targetPtr; + parentPtr->targetsPtr = targetPtr; aliasPtr->targetPtr = targetPtr; Tcl_SetObjResult(interp, aliasPtr->token); - Tcl_Release(slaveInterp); - Tcl_Release(masterInterp); + Tcl_Release(childInterp); + Tcl_Release(parentInterp); return TCL_OK; } @@ -1646,13 +1658,13 @@ AliasCreate( * * AliasDelete -- * - * Deletes the given alias from the slave interpreter given. + * Deletes the given alias from the child interpreter given. * * Results: * A standard Tcl result. * * Side effects: - * Deletes the alias from the slave interpreter. + * Deletes the alias from the child interpreter. * *---------------------------------------------------------------------- */ @@ -1660,21 +1672,21 @@ AliasCreate( static int AliasDelete( Tcl_Interp *interp, /* Interpreter for result & errors. */ - Tcl_Interp *slaveInterp, /* Interpreter containing alias. */ + Tcl_Interp *childInterp, /* Interpreter containing alias. */ Tcl_Obj *namePtr) /* Name of alias to delete. */ { - Slave *slavePtr; + Child *childPtr; Alias *aliasPtr; Tcl_HashEntry *hPtr; /* - * If the alias has been renamed in the slave, the master can still use + * If the alias has been renamed in the child, the parent can still use * the original name (with which it was created) to find the alias to * delete it. */ - slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; - hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr)); + childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; + hPtr = Tcl_FindHashEntry(&childPtr->aliasTable, TclGetString(namePtr)); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "alias \"%s\" not found", TclGetString(namePtr))); @@ -1683,7 +1695,7 @@ AliasDelete( return TCL_ERROR; } aliasPtr = (Alias *)Tcl_GetHashValue(hPtr); - Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); + Tcl_DeleteCommandFromToken(childInterp, aliasPtr->childCmd); return TCL_OK; } @@ -1708,22 +1720,22 @@ AliasDelete( static int AliasDescribe( Tcl_Interp *interp, /* Interpreter for result & errors. */ - Tcl_Interp *slaveInterp, /* Interpreter containing alias. */ + Tcl_Interp *childInterp, /* Interpreter containing alias. */ Tcl_Obj *namePtr) /* Name of alias to describe. */ { - Slave *slavePtr; + Child *childPtr; Tcl_HashEntry *hPtr; Alias *aliasPtr; Tcl_Obj *prefixPtr; /* - * If the alias has been renamed in the slave, the master can still use + * If the alias has been renamed in the child, the parent can still use * the original name (with which it was created) to find the alias to * describe it. */ - slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; - hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr)); + childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; + hPtr = Tcl_FindHashEntry(&childPtr->aliasTable, Tcl_GetString(namePtr)); if (hPtr == NULL) { return TCL_OK; } @@ -1738,7 +1750,7 @@ AliasDescribe( * * AliasList -- * - * Computes a list of aliases defined in a slave interpreter. + * Computes a list of aliases defined in a child interpreter. * * Results: * A standard Tcl result. @@ -1752,17 +1764,18 @@ AliasDescribe( static int AliasList( Tcl_Interp *interp, /* Interp for data return. */ - Tcl_Interp *slaveInterp) /* Interp whose aliases to compute. */ + Tcl_Interp *childInterp) /* Interp whose aliases to compute. */ { Tcl_HashEntry *entryPtr; Tcl_HashSearch hashSearch; - Tcl_Obj *resultPtr = Tcl_NewObj(); + Tcl_Obj *resultPtr; Alias *aliasPtr; - Slave *slavePtr; + Child *childPtr; - slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; + TclNewObj(resultPtr); + childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; - entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch); + entryPtr = Tcl_FirstHashEntry(&childPtr->aliasTable, &hashSearch); for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) { aliasPtr = (Alias *)Tcl_GetHashValue(entryPtr); Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token); @@ -1776,10 +1789,10 @@ AliasList( * * TclAliasObjCmd, TclLocalAliasObjCmd -- * - * This is the function that services invocations of aliases in a slave + * This is the function that services invocations of aliases in a child * interpreter. One such command exists for each alias. When invoked, * this function redirects the invocation to the target command in the - * master interpreter as designated by the Alias record associated with + * parent interpreter as designated by the Alias record associated with * this command. * * TclLocalAliasObjCmd is a stripped down version used when the source @@ -2009,7 +2022,7 @@ TclLocalAliasObjCmd( * * AliasObjCmdDeleteProc -- * - * Is invoked when an alias command is deleted in a slave. Cleans up all + * Is invoked when an alias command is deleted in a child. Cleans up all * storage associated with this alias. * * Results: @@ -2039,17 +2052,17 @@ AliasObjCmdDeleteProc( Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr); /* - * Splice the target record out of the target interpreter's master list. + * Splice the target record out of the target interpreter's parent list. */ targetPtr = aliasPtr->targetPtr; if (targetPtr->prevPtr != NULL) { targetPtr->prevPtr->nextPtr = targetPtr->nextPtr; } else { - Master *masterPtr = &((InterpInfo *) ((Interp *) - aliasPtr->targetInterp)->interpInfo)->master; + Parent *parentPtr = &((InterpInfo *) ((Interp *) + aliasPtr->targetInterp)->interpInfo)->parent; - masterPtr->targetsPtr = targetPtr->nextPtr; + parentPtr->targetsPtr = targetPtr->nextPtr; } if (targetPtr->nextPtr != NULL) { targetPtr->nextPtr->prevPtr = targetPtr->prevPtr; @@ -2062,13 +2075,13 @@ AliasObjCmdDeleteProc( /* *---------------------------------------------------------------------- * - * Tcl_CreateSlave -- + * Tcl_CreateChild -- * - * Creates a slave interpreter. The slavePath argument denotes the name - * of the new slave relative to the current interpreter; the slave is a + * Creates a child interpreter. The childPath argument denotes the name + * of the new child relative to the current interpreter; the child is a * direct descendant of the one-before-last component of the path, - * e.g. it is a descendant of the current interpreter if the slavePath - * argument contains only one component. Optionally makes the slave + * e.g. it is a descendant of the current interpreter if the childPath + * argument contains only one component. Optionally makes the child * interpreter safe. * * Results: @@ -2077,33 +2090,33 @@ AliasObjCmdDeleteProc( * * Side effects: * Creates a new interpreter and a new interpreter object command in the - * interpreter indicated by the slavePath argument. + * interpreter indicated by the childPath argument. * *---------------------------------------------------------------------- */ Tcl_Interp * -Tcl_CreateSlave( +Tcl_CreateChild( Tcl_Interp *interp, /* Interpreter to start search at. */ - const char *slavePath, /* Name of slave to create. */ - int isSafe) /* Should new slave be "safe" ? */ + const char *childPath, /* Name of child to create. */ + int isSafe) /* Should new child be "safe" ? */ { Tcl_Obj *pathPtr; - Tcl_Interp *slaveInterp; + Tcl_Interp *childInterp; - pathPtr = Tcl_NewStringObj(slavePath, -1); - slaveInterp = SlaveCreate(interp, pathPtr, isSafe); + pathPtr = Tcl_NewStringObj(childPath, -1); + childInterp = ChildCreate(interp, pathPtr, isSafe); Tcl_DecrRefCount(pathPtr); - return slaveInterp; + return childInterp; } /* *---------------------------------------------------------------------- * - * Tcl_GetSlave -- + * Tcl_GetChild -- * - * Finds a slave interpreter by its path name. + * Finds a child interpreter by its path name. * * Results: * Returns a Tcl_Interp * for the named interpreter or NULL if not found. @@ -2115,29 +2128,29 @@ Tcl_CreateSlave( */ Tcl_Interp * -Tcl_GetSlave( +Tcl_GetChild( Tcl_Interp *interp, /* Interpreter to start search from. */ - const char *slavePath) /* Path of slave to find. */ + const char *childPath) /* Path of child to find. */ { Tcl_Obj *pathPtr; - Tcl_Interp *slaveInterp; + Tcl_Interp *childInterp; - pathPtr = Tcl_NewStringObj(slavePath, -1); - slaveInterp = GetInterp(interp, pathPtr); + pathPtr = Tcl_NewStringObj(childPath, -1); + childInterp = GetInterp(interp, pathPtr); Tcl_DecrRefCount(pathPtr); - return slaveInterp; + return childInterp; } /* *---------------------------------------------------------------------- * - * Tcl_GetMaster -- + * Tcl_GetParent -- * - * Finds the master interpreter of a slave interpreter. + * Finds the parent interpreter of a child interpreter. * * Results: - * Returns a Tcl_Interp * for the master interpreter or NULL if none. + * Returns a Tcl_Interp * for the parent interpreter or NULL if none. * * Side effects: * None. @@ -2146,16 +2159,16 @@ Tcl_GetSlave( */ Tcl_Interp * -Tcl_GetMaster( - Tcl_Interp *interp) /* Get the master of this interpreter. */ +Tcl_GetParent( + Tcl_Interp *interp) /* Get the parent of this interpreter. */ { - Slave *slavePtr; /* Slave record of this interpreter. */ + Child *childPtr; /* Child record of this interpreter. */ if (interp == NULL) { return NULL; } - slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave; - return slavePtr->masterInterp; + childPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->child; + return childPtr->parentInterp; } /* @@ -2163,7 +2176,7 @@ Tcl_GetMaster( * * TclSetChildCancelFlags -- * - * This function marks all slave interpreters belonging to a given + * This function marks all child interpreters belonging to a given * interpreter as being canceled or not canceled, depending on the * provided flags. * @@ -2186,10 +2199,10 @@ TclSetChildCancelFlags( int force) /* Non-zero to ignore numLevels for the purpose * of resetting the cancellation flags. */ { - Master *masterPtr; /* Master record of given interpreter. */ + Parent *parentPtr; /* Parent record of given interpreter. */ Tcl_HashEntry *hPtr; /* Search element. */ Tcl_HashSearch hashSearch; /* Search variable. */ - Slave *slavePtr; /* Slave record of interpreter. */ + Child *childPtr; /* Child record of interpreter. */ Interp *iPtr; if (interp == NULL) { @@ -2198,12 +2211,12 @@ TclSetChildCancelFlags( flags &= (CANCELED | TCL_CANCEL_UNWIND); - masterPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->master; + parentPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->parent; - hPtr = Tcl_FirstHashEntry(&masterPtr->slaveTable, &hashSearch); + hPtr = Tcl_FirstHashEntry(&parentPtr->childTable, &hashSearch); for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { - slavePtr = (Slave *)Tcl_GetHashValue(hPtr); - iPtr = (Interp *) slavePtr->slaveInterp; + childPtr = (Child *)Tcl_GetHashValue(hPtr); + iPtr = (Interp *) childPtr->childInterp; if (iPtr == NULL) { continue; @@ -2216,7 +2229,7 @@ TclSetChildCancelFlags( } /* - * Now, recursively handle this for the slaves of this slave + * Now, recursively handle this for the children of this child * interpreter. */ @@ -2232,7 +2245,7 @@ TclSetChildCancelFlags( * Sets the result of the asking interpreter to a proper Tcl list * containing the names of interpreters between the asking and target * interpreters. The target interpreter must be either the same as the - * asking interpreter or one of its slaves (including recursively). + * asking interpreter or one of its children (including recursively). * * Results: * TCL_OK if the target interpreter is the same as, or a descendant of, @@ -2263,12 +2276,12 @@ Tcl_GetInterpPath( return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo; - if (Tcl_GetInterpPath(interp, iiPtr->slave.masterInterp) != TCL_OK){ + if (Tcl_GetInterpPath(interp, iiPtr->child.parentInterp) != TCL_OK){ return TCL_ERROR; } Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), - Tcl_NewStringObj((const char *)Tcl_GetHashKey(&iiPtr->master.slaveTable, - iiPtr->slave.slaveEntryPtr), -1)); + Tcl_NewStringObj((const char *)Tcl_GetHashKey(&iiPtr->parent.childTable, + iiPtr->child.childEntryPtr), -1)); return TCL_OK; } @@ -2277,10 +2290,10 @@ Tcl_GetInterpPath( * * GetInterp -- * - * Helper function to find a slave interpreter given a pathname. + * Helper function to find a child interpreter given a pathname. * * Results: - * Returns the slave interpreter known by that name in the calling + * Returns the child interpreter known by that name in the calling * interpreter, or NULL if no interpreter known by that name exists. * * Side effects: @@ -2296,11 +2309,11 @@ GetInterp( * be found. */ { Tcl_HashEntry *hPtr; /* Search element. */ - Slave *slavePtr; /* Interim slave record. */ + Child *childPtr; /* Interim child record. */ Tcl_Obj **objv; int objc, i; Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ - InterpInfo *masterInfoPtr; + InterpInfo *parentInfoPtr; if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; @@ -2308,15 +2321,15 @@ GetInterp( searchInterp = interp; for (i = 0; i < objc; i++) { - masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo; - hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable, + parentInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo; + hPtr = Tcl_FindHashEntry(&parentInfoPtr->parent.childTable, TclGetString(objv[i])); if (hPtr == NULL) { searchInterp = NULL; break; } - slavePtr = (Slave *)Tcl_GetHashValue(hPtr); - searchInterp = slavePtr->slaveInterp; + childPtr = (Child *)Tcl_GetHashValue(hPtr); + searchInterp = childPtr->childInterp; if (searchInterp == NULL) { break; } @@ -2333,7 +2346,7 @@ GetInterp( /* *---------------------------------------------------------------------- * - * SlaveBgerror -- + * ChildBgerror -- * * Helper function to set/query the background error handling command * prefix of an interp @@ -2342,16 +2355,16 @@ GetInterp( * A standard Tcl result. * * Side effects: - * When (objc == 1), slaveInterp will be set to a new background handler + * When (objc == 1), childInterp will be set to a new background handler * of objv[0]. * *---------------------------------------------------------------------- */ static int -SlaveBgerror( +ChildBgerror( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* Interp in which limit is set/queried. */ + Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */ int objc, /* Set or Query. */ Tcl_Obj *const objv[]) /* Argument strings. */ { @@ -2366,19 +2379,19 @@ SlaveBgerror( "BGERRORFORMAT", NULL); return TCL_ERROR; } - TclSetBgErrorHandler(slaveInterp, objv[0]); + TclSetBgErrorHandler(childInterp, objv[0]); } - Tcl_SetObjResult(interp, TclGetBgErrorHandler(slaveInterp)); + Tcl_SetObjResult(interp, TclGetBgErrorHandler(childInterp)); return TCL_OK; } /* *---------------------------------------------------------------------- * - * SlaveCreate -- + * ChildCreate -- * - * Helper function to do the actual work of creating a slave interp and - * new object command. Also optionally makes the new slave interpreter + * Helper function to do the actual work of creating a child interp and + * new object command. Also optionally makes the new child interpreter * "safe". * * Results: @@ -2386,20 +2399,20 @@ SlaveBgerror( * the result of the invoking interpreter contains an error message. * * Side effects: - * Creates a new slave interpreter and a new object command. + * Creates a new child interpreter and a new object command. * *---------------------------------------------------------------------- */ static Tcl_Interp * -SlaveCreate( +ChildCreate( Tcl_Interp *interp, /* Interp. to start search from. */ - Tcl_Obj *pathPtr, /* Path (name) of slave to create. */ + Tcl_Obj *pathPtr, /* Path (name) of child to create. */ int safe) /* Should we make it "safe"? */ { - Tcl_Interp *masterInterp, *slaveInterp; - Slave *slavePtr; - InterpInfo *masterInfoPtr; + Tcl_Interp *parentInterp, *childInterp; + Child *childPtr; + InterpInfo *parentInfoPtr; Tcl_HashEntry *hPtr; const char *path; int isNew, objc; @@ -2409,25 +2422,25 @@ SlaveCreate( return NULL; } if (objc < 2) { - masterInterp = interp; + parentInterp = interp; path = TclGetString(pathPtr); } else { Tcl_Obj *objPtr; objPtr = Tcl_NewListObj(objc - 1, objv); - masterInterp = GetInterp(interp, objPtr); + parentInterp = GetInterp(interp, objPtr); Tcl_DecrRefCount(objPtr); - if (masterInterp == NULL) { + if (parentInterp == NULL) { return NULL; } path = TclGetString(objv[objc - 1]); } if (safe == 0) { - safe = Tcl_IsSafe(masterInterp); + safe = Tcl_IsSafe(parentInterp); } - masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo; - hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, + parentInfoPtr = (InterpInfo *) ((Interp *) parentInterp)->interpInfo; + hPtr = Tcl_CreateHashEntry(&parentInfoPtr->parent.childTable, path, &isNew); if (isNew == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2436,51 +2449,51 @@ SlaveCreate( return NULL; } - slaveInterp = Tcl_CreateInterp(); - slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; - slavePtr->masterInterp = masterInterp; - slavePtr->slaveEntryPtr = hPtr; - slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path, - TclSlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); - Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); - Tcl_SetHashValue(hPtr, slavePtr); - Tcl_SetVar2(slaveInterp, "tcl_interactive", NULL, "0", TCL_GLOBAL_ONLY); + childInterp = Tcl_CreateInterp(); + childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; + childPtr->parentInterp = parentInterp; + childPtr->childEntryPtr = hPtr; + childPtr->childInterp = childInterp; + childPtr->interpCmd = Tcl_NRCreateCommand(parentInterp, path, + TclChildObjCmd, NRChildCmd, childInterp, ChildObjCmdDeleteProc); + Tcl_InitHashTable(&childPtr->aliasTable, TCL_STRING_KEYS); + Tcl_SetHashValue(hPtr, childPtr); + Tcl_SetVar2(childInterp, "tcl_interactive", NULL, "0", TCL_GLOBAL_ONLY); /* * Inherit the recursion limit. */ - ((Interp *) slaveInterp)->maxNestingDepth = - ((Interp *) masterInterp)->maxNestingDepth; + ((Interp *) childInterp)->maxNestingDepth = + ((Interp *) parentInterp)->maxNestingDepth; if (safe) { - if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) { + if (Tcl_MakeSafe(childInterp) == TCL_ERROR) { goto error; } } else { - if (Tcl_Init(slaveInterp) == TCL_ERROR) { + if (Tcl_Init(childInterp) == TCL_ERROR) { goto error; } /* - * This will create the "memory" command in slave interpreters if we + * This will create the "memory" command in child interpreters if we * compiled with TCL_MEM_DEBUG, otherwise it does nothing. */ - Tcl_InitMemory(slaveInterp); + Tcl_InitMemory(childInterp); } /* * Inherit the TIP#143 limits. */ - InheritLimitsFromMaster(slaveInterp, masterInterp); + InheritLimitsFromParent(childInterp, parentInterp); /* * The [clock] command presents a safe API, but uses unsafe features in * its implementation. This means it has to be implemented in safe interps - * as an alias to a version in the (trusted) master. + * as an alias to a version in the (trusted) parent. */ if (safe) { @@ -2489,7 +2502,7 @@ SlaveCreate( TclNewLiteralStringObj(clockObj, "clock"); Tcl_IncrRefCount(clockObj); - status = AliasCreate(interp, slaveInterp, masterInterp, clockObj, + status = AliasCreate(interp, childInterp, parentInterp, clockObj, clockObj, 0, NULL); Tcl_DecrRefCount(clockObj); if (status != TCL_OK) { @@ -2497,12 +2510,12 @@ SlaveCreate( } } - return slaveInterp; + return childInterp; error: - Tcl_TransferResult(slaveInterp, TCL_ERROR, interp); + Tcl_TransferResult(childInterp, TCL_ERROR, interp); error2: - Tcl_DeleteInterp(slaveInterp); + Tcl_DeleteInterp(childInterp); return NULL; } @@ -2510,10 +2523,10 @@ SlaveCreate( /* *---------------------------------------------------------------------- * - * TclSlaveObjCmd -- + * TclChildObjCmd -- * * Command to manipulate an interpreter, e.g. to send commands to it to - * be evaluated. One such command exists for each slave interpreter. + * be evaluated. One such command exists for each child interpreter. * * Results: * A standard Tcl result. @@ -2525,23 +2538,23 @@ SlaveCreate( */ int -TclSlaveObjCmd( - ClientData clientData, /* Slave interpreter. */ +TclChildObjCmd( + ClientData clientData, /* Child interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv); + return Tcl_NRCallObjProc(interp, NRChildCmd, clientData, objc, objv); } static int -NRSlaveCmd( - ClientData clientData, /* Slave interpreter. */ +NRChildCmd( + ClientData clientData, /* Child interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Interp *slaveInterp = (Tcl_Interp *)clientData; + Tcl_Interp *childInterp = (Tcl_Interp *)clientData; int index; static const char *const options[] = { "alias", "aliases", "bgerror", "debug", @@ -2549,15 +2562,15 @@ NRSlaveCmd( "issafe", "invokehidden", "limit", "marktrusted", "recursionlimit", NULL }; - enum options { + enum childCmdOptionsEnum { OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_DEBUG, OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT }; - if (slaveInterp == NULL) { - Tcl_Panic("TclSlaveObjCmd: interpreter has been deleted"); + if (childInterp == NULL) { + Tcl_Panic("TclChildObjCmd: interpreter has been deleted"); } if (objc < 2) { @@ -2569,18 +2582,18 @@ NRSlaveCmd( return TCL_ERROR; } - switch ((enum options) index) { + switch ((enum childCmdOptionsEnum) index) { case OPT_ALIAS: if (objc > 2) { if (objc == 3) { - return AliasDescribe(interp, slaveInterp, objv[2]); + return AliasDescribe(interp, childInterp, objv[2]); } if (TclGetString(objv[3])[0] == '\0') { if (objc == 4) { - return AliasDelete(interp, slaveInterp, objv[2]); + return AliasDelete(interp, childInterp, objv[2]); } } else { - return AliasCreate(interp, slaveInterp, interp, objv[2], + return AliasCreate(interp, childInterp, interp, objv[2], objv[3], objc - 4, objv + 4); } } @@ -2591,13 +2604,13 @@ NRSlaveCmd( Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - return AliasList(interp, slaveInterp); + return AliasList(interp, childInterp); case OPT_BGERROR: if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?"); return TCL_ERROR; } - return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2); + return ChildBgerror(interp, childInterp, objc - 2, objv + 2); case OPT_DEBUG: /* * TIP #378 @@ -2607,37 +2620,37 @@ NRSlaveCmd( Tcl_WrongNumArgs(interp, 2, objv, "?-frame ?bool??"); return TCL_ERROR; } - return SlaveDebugCmd(interp, slaveInterp, objc - 2, objv + 2); + return ChildDebugCmd(interp, childInterp, objc - 2, objv + 2); case OPT_EVAL: if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); return TCL_ERROR; } - return SlaveEval(interp, slaveInterp, objc - 2, objv + 2); + return ChildEval(interp, childInterp, objc - 2, objv + 2); case OPT_EXPOSE: if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?"); return TCL_ERROR; } - return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2); + return ChildExpose(interp, childInterp, objc - 2, objv + 2); case OPT_HIDE: if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?"); return TCL_ERROR; } - return SlaveHide(interp, slaveInterp, objc - 2, objv + 2); + return ChildHide(interp, childInterp, objc - 2, objv + 2); case OPT_HIDDEN: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - return SlaveHidden(interp, slaveInterp); + return ChildHidden(interp, childInterp); case OPT_ISSAFE: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(childInterp))); return TCL_OK; case OPT_INVOKEHIDDEN: { int i; @@ -2676,7 +2689,7 @@ NRSlaveCmd( "?-namespace ns? ?-global? ?--? cmd ?arg ..?"); return TCL_ERROR; } - return SlaveInvokeHidden(interp, slaveInterp, namespaceName, + return ChildInvokeHidden(interp, childInterp, namespaceName, objc - i, objv + i); } case OPT_LIMIT: { @@ -2698,9 +2711,9 @@ NRSlaveCmd( } switch ((enum LimitTypes) limitType) { case LIMIT_TYPE_COMMANDS: - return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv); + return ChildCommandLimitCmd(interp, childInterp, 3, objc,objv); case LIMIT_TYPE_TIME: - return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv); + return ChildTimeLimitCmd(interp, childInterp, 3, objc, objv); } } break; @@ -2709,13 +2722,13 @@ NRSlaveCmd( Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - return SlaveMarkTrusted(interp, slaveInterp); + return ChildMarkTrusted(interp, childInterp); case OPT_RECLIMIT: if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?"); return TCL_ERROR; } - return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2); + return ChildRecursionLimit(interp, childInterp, objc - 2, objv + 2); } return TCL_ERROR; @@ -2724,71 +2737,71 @@ NRSlaveCmd( /* *---------------------------------------------------------------------- * - * SlaveObjCmdDeleteProc -- + * ChildObjCmdDeleteProc -- * - * Invoked when an object command for a slave interpreter is deleted; - * cleans up all state associated with the slave interpreter and destroys - * the slave interpreter. + * Invoked when an object command for a child interpreter is deleted; + * cleans up all state associated with the child interpreter and destroys + * the child interpreter. * * Results: * None. * * Side effects: - * Cleans up all state associated with the slave interpreter and destroys - * the slave interpreter. + * Cleans up all state associated with the child interpreter and destroys + * the child interpreter. * *---------------------------------------------------------------------- */ static void -SlaveObjCmdDeleteProc( - ClientData clientData) /* The SlaveRecord for the command. */ +ChildObjCmdDeleteProc( + ClientData clientData) /* The ChildRecord for the command. */ { - Slave *slavePtr; /* Interim storage for Slave record. */ - Tcl_Interp *slaveInterp = (Tcl_Interp *)clientData; - /* And for a slave interp. */ + Child *childPtr; /* Interim storage for Child record. */ + Tcl_Interp *childInterp = (Tcl_Interp *)clientData; + /* And for a child interp. */ - slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; + childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; /* - * Unlink the slave from its master interpreter. + * Unlink the child from its parent interpreter. */ - Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr); + Tcl_DeleteHashEntry(childPtr->childEntryPtr); /* - * Set to NULL so that when the InterpInfo is cleaned up in the slave it + * Set to NULL so that when the InterpInfo is cleaned up in the child it * does not try to delete the command causing all sorts of grief. See - * SlaveRecordDeleteProc(). + * ChildRecordDeleteProc(). */ - slavePtr->interpCmd = NULL; + childPtr->interpCmd = NULL; - if (slavePtr->slaveInterp != NULL) { - Tcl_DeleteInterp(slavePtr->slaveInterp); + if (childPtr->childInterp != NULL) { + Tcl_DeleteInterp(childPtr->childInterp); } } /* *---------------------------------------------------------------------- * - * SlaveDebugCmd -- TIP #378 + * ChildDebugCmd -- TIP #378 * - * Helper function to handle 'debug' command in a slave interpreter. + * Helper function to handle 'debug' command in a child interpreter. * * Results: * A standard Tcl result. * * Side effects: - * May modify INTERP_DEBUG_FRAME flag in the slave. + * May modify INTERP_DEBUG_FRAME flag in the child. * *---------------------------------------------------------------------- */ static int -SlaveDebugCmd( +ChildDebugCmd( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* The slave interpreter in which command + Tcl_Interp *childInterp, /* The child interpreter in which command * will be evaluated. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2803,9 +2816,9 @@ SlaveDebugCmd( Interp *iPtr; Tcl_Obj *resultPtr; - iPtr = (Interp *) slaveInterp; + iPtr = (Interp *) childInterp; if (objc == 0) { - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj("-frame", -1)); Tcl_ListObjAppendElement(NULL, resultPtr, @@ -2843,9 +2856,9 @@ SlaveDebugCmd( /* *---------------------------------------------------------------------- * - * SlaveEval -- + * ChildEval -- * - * Helper function to evaluate a command in a slave interpreter. + * Helper function to evaluate a command in a child interpreter. * * Results: * A standard Tcl result. @@ -2857,9 +2870,9 @@ SlaveDebugCmd( */ static int -SlaveEval( +ChildEval( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* The slave interpreter in which command + Tcl_Interp *childInterp, /* The child interpreter in which command * will be evaluated. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2867,17 +2880,17 @@ SlaveEval( int result; /* - * TIP #285: If necessary, reset the cancellation flags for the slave - * interpreter now; otherwise, canceling a script in a master interpreter - * can result in a situation where a slave interpreter can no longer + * TIP #285: If necessary, reset the cancellation flags for the child + * interpreter now; otherwise, canceling a script in a parent interpreter + * can result in a situation where a child interpreter can no longer * evaluate any scripts unless somebody calls the TclResetCancellation * function for that particular Tcl_Interp. */ - TclSetChildCancelFlags(slaveInterp, 0, 0); + TclSetChildCancelFlags(childInterp, 0, 0); - Tcl_Preserve(slaveInterp); - Tcl_AllowExceptions(slaveInterp); + Tcl_Preserve(childInterp); + Tcl_AllowExceptions(childInterp); if (objc == 1) { /* @@ -2890,40 +2903,40 @@ SlaveEval( TclArgumentGet(interp, objv[0], &invoker, &word); - result = TclEvalObjEx(slaveInterp, objv[0], 0, invoker, word); + result = TclEvalObjEx(childInterp, objv[0], 0, invoker, word); } else { Tcl_Obj *objPtr = Tcl_ConcatObj(objc, objv); Tcl_IncrRefCount(objPtr); - result = Tcl_EvalObjEx(slaveInterp, objPtr, 0); + result = Tcl_EvalObjEx(childInterp, objPtr, 0); Tcl_DecrRefCount(objPtr); } - Tcl_TransferResult(slaveInterp, result, interp); + Tcl_TransferResult(childInterp, result, interp); - Tcl_Release(slaveInterp); + Tcl_Release(childInterp); return result; } /* *---------------------------------------------------------------------- * - * SlaveExpose -- + * ChildExpose -- * - * Helper function to expose a command in a slave interpreter. + * Helper function to expose a command in a child interpreter. * * Results: * A standard Tcl result. * * Side effects: - * After this call scripts in the slave will be able to invoke the newly + * After this call scripts in the child will be able to invoke the newly * exposed command. * *---------------------------------------------------------------------- */ static int -SlaveExpose( +ChildExpose( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* Interp in which command will be exposed. */ + Tcl_Interp *childInterp, /* Interp in which command will be exposed. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { @@ -2939,9 +2952,9 @@ SlaveExpose( } name = TclGetString(objv[(objc == 1) ? 0 : 1]); - if (Tcl_ExposeCommand(slaveInterp, TclGetString(objv[0]), + if (Tcl_ExposeCommand(childInterp, TclGetString(objv[0]), name) != TCL_OK) { - Tcl_TransferResult(slaveInterp, TCL_ERROR, interp); + Tcl_TransferResult(childInterp, TCL_ERROR, interp); return TCL_ERROR; } return TCL_OK; @@ -2950,7 +2963,7 @@ SlaveExpose( /* *---------------------------------------------------------------------- * - * SlaveRecursionLimit -- + * ChildRecursionLimit -- * * Helper function to set/query the Recursion limit of an interp * @@ -2958,16 +2971,16 @@ SlaveExpose( * A standard Tcl result. * * Side effects: - * When (objc == 1), slaveInterp will be set to a new recursion limit of + * When (objc == 1), childInterp will be set to a new recursion limit of * objv[0]. * *---------------------------------------------------------------------- */ static int -SlaveRecursionLimit( +ChildRecursionLimit( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* Interp in which limit is set/queried. */ + Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */ int objc, /* Set or Query. */ Tcl_Obj *const objv[]) /* Argument strings. */ { @@ -2992,9 +3005,9 @@ SlaveRecursionLimit( NULL); return TCL_ERROR; } - Tcl_SetRecursionLimit(slaveInterp, limit); - iPtr = (Interp *) slaveInterp; - if (interp == slaveInterp && iPtr->numLevels > limit) { + Tcl_SetRecursionLimit(childInterp, limit); + iPtr = (Interp *) childInterp; + if (interp == childInterp && iPtr->numLevels > limit) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "falling back due to new recursion limit", -1)); Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL); @@ -3003,7 +3016,7 @@ SlaveRecursionLimit( Tcl_SetObjResult(interp, objv[0]); return TCL_OK; } else { - limit = Tcl_SetRecursionLimit(slaveInterp, 0); + limit = Tcl_SetRecursionLimit(childInterp, 0); Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limit)); return TCL_OK; } @@ -3012,24 +3025,24 @@ SlaveRecursionLimit( /* *---------------------------------------------------------------------- * - * SlaveHide -- + * ChildHide -- * - * Helper function to hide a command in a slave interpreter. + * Helper function to hide a command in a child interpreter. * * Results: * A standard Tcl result. * * Side effects: - * After this call scripts in the slave will no longer be able to invoke + * After this call scripts in the child will no longer be able to invoke * the named command. * *---------------------------------------------------------------------- */ static int -SlaveHide( +ChildHide( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* Interp in which command will be exposed. */ + Tcl_Interp *childInterp, /* Interp in which command will be exposed. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { @@ -3045,8 +3058,8 @@ SlaveHide( } name = TclGetString(objv[(objc == 1) ? 0 : 1]); - if (Tcl_HideCommand(slaveInterp, TclGetString(objv[0]), name) != TCL_OK) { - Tcl_TransferResult(slaveInterp, TCL_ERROR, interp); + if (Tcl_HideCommand(childInterp, TclGetString(objv[0]), name) != TCL_OK) { + Tcl_TransferResult(childInterp, TCL_ERROR, interp); return TCL_ERROR; } return TCL_OK; @@ -3055,9 +3068,9 @@ SlaveHide( /* *---------------------------------------------------------------------- * - * SlaveHidden -- + * ChildHidden -- * - * Helper function to compute list of hidden commands in a slave + * Helper function to compute list of hidden commands in a child * interpreter. * * Results: @@ -3070,16 +3083,17 @@ SlaveHide( */ static int -SlaveHidden( +ChildHidden( Tcl_Interp *interp, /* Interp for data return. */ - Tcl_Interp *slaveInterp) /* Interp whose hidden commands to query. */ + Tcl_Interp *childInterp) /* Interp whose hidden commands to query. */ { - Tcl_Obj *listObjPtr = Tcl_NewObj(); /* Local object pointer. */ + Tcl_Obj *listObjPtr; /* Local object pointer. */ Tcl_HashTable *hTblPtr; /* For local searches. */ Tcl_HashEntry *hPtr; /* For local searches. */ Tcl_HashSearch hSearch; /* For local searches. */ - hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr; + TclNewObj(listObjPtr); + hTblPtr = ((Interp *) childInterp)->hiddenCmdTablePtr; if (hTblPtr != NULL) { for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL; @@ -3095,9 +3109,9 @@ SlaveHidden( /* *---------------------------------------------------------------------- * - * SlaveInvokeHidden -- + * ChildInvokeHidden -- * - * Helper function to invoke a hidden command in a slave interpreter. + * Helper function to invoke a hidden command in a child interpreter. * * Results: * A standard Tcl result. @@ -3109,9 +3123,9 @@ SlaveHidden( */ static int -SlaveInvokeHidden( +ChildInvokeHidden( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp, /* The slave interpreter in which command will + Tcl_Interp *childInterp, /* The child interpreter in which command will * be invoked. */ const char *namespaceName, /* The namespace to use, if any. */ int objc, /* Number of arguments. */ @@ -3128,31 +3142,31 @@ SlaveInvokeHidden( return TCL_ERROR; } - Tcl_Preserve(slaveInterp); - Tcl_AllowExceptions(slaveInterp); + Tcl_Preserve(childInterp); + Tcl_AllowExceptions(childInterp); if (namespaceName == NULL) { - NRE_callback *rootPtr = TOP_CB(slaveInterp); + NRE_callback *rootPtr = TOP_CB(childInterp); - Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, + Tcl_NRAddCallback(interp, NRPostInvokeHidden, childInterp, rootPtr, NULL, NULL); - return TclNRInvoke(NULL, slaveInterp, objc, objv); + return TclNRInvoke(NULL, childInterp, objc, objv); } else { Namespace *nsPtr, *dummy1, *dummy2; const char *tail; - result = TclGetNamespaceForQualName(slaveInterp, namespaceName, NULL, + result = TclGetNamespaceForQualName(childInterp, namespaceName, NULL, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG | TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); if (result == TCL_OK) { - result = TclObjInvokeNamespace(slaveInterp, objc, objv, + result = TclObjInvokeNamespace(childInterp, objc, objv, (Tcl_Namespace *) nsPtr, TCL_INVOKE_HIDDEN); } } - Tcl_TransferResult(slaveInterp, result, interp); + Tcl_TransferResult(childInterp, result, interp); - Tcl_Release(slaveInterp); + Tcl_Release(childInterp); return result; } @@ -3162,38 +3176,38 @@ NRPostInvokeHidden( Tcl_Interp *interp, int result) { - Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0]; + Tcl_Interp *childInterp = (Tcl_Interp *)data[0]; NRE_callback *rootPtr = (NRE_callback *)data[1]; - if (interp != slaveInterp) { - result = TclNRRunCallbacks(slaveInterp, result, rootPtr); - Tcl_TransferResult(slaveInterp, result, interp); + if (interp != childInterp) { + result = TclNRRunCallbacks(childInterp, result, rootPtr); + Tcl_TransferResult(childInterp, result, interp); } - Tcl_Release(slaveInterp); + Tcl_Release(childInterp); return result; } /* *---------------------------------------------------------------------- * - * SlaveMarkTrusted -- + * ChildMarkTrusted -- * - * Helper function to mark a slave interpreter as trusted (unsafe). + * Helper function to mark a child interpreter as trusted (unsafe). * * Results: * A standard Tcl result. * * Side effects: * After this call the hard-wired security checks in the core no longer - * prevent the slave from performing certain operations. + * prevent the child from performing certain operations. * *---------------------------------------------------------------------- */ static int -SlaveMarkTrusted( +ChildMarkTrusted( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *slaveInterp) /* The slave interpreter which will be marked + Tcl_Interp *childInterp) /* The child interpreter which will be marked * trusted. */ { if (Tcl_IsSafe(interp)) { @@ -3204,7 +3218,7 @@ SlaveMarkTrusted( NULL); return TCL_ERROR; } - ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP; + ((Interp *) childInterp)->flags &= ~SAFE_INTERP; return TCL_OK; } @@ -3261,14 +3275,14 @@ Tcl_MakeSafe( { Tcl_Channel chan; /* Channel to remove from safe interpreter. */ Interp *iPtr = (Interp *) interp; - Tcl_Interp *master = ((InterpInfo*) iPtr->interpInfo)->slave.masterInterp; + Tcl_Interp *parent = ((InterpInfo*) iPtr->interpInfo)->child.parentInterp; TclHideUnsafeCommands(interp); - if (master != NULL) { + if (parent != NULL) { /* - * Alias these function implementations in the slave to those in the - * master; the overall implementations are safe, but they're normally + * Alias these function implementations in the child to those in the + * parent; the overall implementations are safe, but they're normally * defined by init.tcl which is not sourced by safe interpreters. * Assume these functions all work. [Bug 2895741] */ @@ -3285,7 +3299,7 @@ Tcl_MakeSafe( */ /* - * No env array in a safe slave. + * No env array in a safe interpreter. */ Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY); @@ -4186,7 +4200,7 @@ Tcl_LimitGetGranularity( * DeleteScriptLimitCallback -- * * Callback for when a script limit (a limit callback implemented as a - * Tcl script in a master interpreter, as set up from Tcl) is deleted. + * Tcl script in a parent interpreter, as set up from Tcl) is deleted. * * Results: * None. @@ -4399,48 +4413,48 @@ TclInitLimitSupport( /* *---------------------------------------------------------------------- * - * InheritLimitsFromMaster -- + * InheritLimitsFromParent -- * - * Derive the interpreter limit configuration for a slave interpreter - * from the limit config for the master. + * Derive the interpreter limit configuration for a child interpreter + * from the limit config for the parent. * * Results: * None. * * Side effects: - * The slave interpreter limits are set so that if the master has a - * limit, it may not exceed it by handing off work to slave interpreters. - * Note that this does not transfer limit callbacks from the master to - * the slave. + * The child interpreter limits are set so that if the parent has a + * limit, it may not exceed it by handing off work to child interpreters. + * Note that this does not transfer limit callbacks from the parent to + * the child. * *---------------------------------------------------------------------- */ static void -InheritLimitsFromMaster( - Tcl_Interp *slaveInterp, - Tcl_Interp *masterInterp) +InheritLimitsFromParent( + Tcl_Interp *childInterp, + Tcl_Interp *parentInterp) { - Interp *slavePtr = (Interp *) slaveInterp; - Interp *masterPtr = (Interp *) masterInterp; + Interp *childPtr = (Interp *) childInterp; + Interp *parentPtr = (Interp *) parentInterp; - if (masterPtr->limit.active & TCL_LIMIT_COMMANDS) { - slavePtr->limit.active |= TCL_LIMIT_COMMANDS; - slavePtr->limit.cmdCount = 0; - slavePtr->limit.cmdGranularity = masterPtr->limit.cmdGranularity; + if (parentPtr->limit.active & TCL_LIMIT_COMMANDS) { + childPtr->limit.active |= TCL_LIMIT_COMMANDS; + childPtr->limit.cmdCount = 0; + childPtr->limit.cmdGranularity = parentPtr->limit.cmdGranularity; } - if (masterPtr->limit.active & TCL_LIMIT_TIME) { - slavePtr->limit.active |= TCL_LIMIT_TIME; - memcpy(&slavePtr->limit.time, &masterPtr->limit.time, + if (parentPtr->limit.active & TCL_LIMIT_TIME) { + childPtr->limit.active |= TCL_LIMIT_TIME; + memcpy(&childPtr->limit.time, &parentPtr->limit.time, sizeof(Tcl_Time)); - slavePtr->limit.timeGranularity = masterPtr->limit.timeGranularity; + childPtr->limit.timeGranularity = parentPtr->limit.timeGranularity; } } /* *---------------------------------------------------------------------- * - * SlaveCommandLimitCmd -- + * ChildCommandLimitCmd -- * * Implementation of the [interp limit $i commands] and [$i limit * commands] subcommands. See the interp manual page for a full @@ -4456,9 +4470,9 @@ InheritLimitsFromMaster( */ static int -SlaveCommandLimitCmd( +ChildCommandLimitCmd( Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Interp *slaveInterp, /* Interpreter being adjusted. */ + Tcl_Interp *childInterp, /* Interpreter being adjusted. */ int consumedObjc, /* Number of args already parsed. */ int objc, /* Total number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -4482,7 +4496,7 @@ SlaveCommandLimitCmd( * avoid. [Bug 3398794] */ - if (interp == slaveInterp) { + if (interp == childInterp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "limits on current interpreter inaccessible", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); @@ -4493,7 +4507,7 @@ SlaveCommandLimitCmd( Tcl_Obj *dictPtr; TclNewObj(dictPtr); - key.interp = slaveInterp; + key.interp = childInterp; key.type = TCL_LIMIT_COMMANDS; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { @@ -4513,12 +4527,12 @@ SlaveCommandLimitCmd( Tcl_NewStringObj(options[0], -1), empty); } Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), - Tcl_NewWideIntObj(Tcl_LimitGetGranularity(slaveInterp, + Tcl_NewWideIntObj(Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_COMMANDS))); - if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) { + if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) { Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), - Tcl_NewWideIntObj(Tcl_LimitGetCommands(slaveInterp))); + Tcl_NewWideIntObj(Tcl_LimitGetCommands(childInterp))); } else { Tcl_Obj *empty; @@ -4535,7 +4549,7 @@ SlaveCommandLimitCmd( } switch ((enum Options) index) { case OPT_CMD: - key.interp = slaveInterp; + key.interp = childInterp; key.type = TCL_LIMIT_COMMANDS; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { @@ -4547,12 +4561,12 @@ SlaveCommandLimitCmd( break; case OPT_GRAN: Tcl_SetObjResult(interp, Tcl_NewWideIntObj( - Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_COMMANDS))); + Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_COMMANDS))); break; case OPT_VAL: - if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) { + if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) { Tcl_SetObjResult(interp, - Tcl_NewWideIntObj(Tcl_LimitGetCommands(slaveInterp))); + Tcl_NewWideIntObj(Tcl_LimitGetCommands(childInterp))); } break; } @@ -4608,18 +4622,18 @@ SlaveCommandLimitCmd( } } if (scriptObj != NULL) { - SetScriptLimitCallback(interp, TCL_LIMIT_COMMANDS, slaveInterp, + SetScriptLimitCallback(interp, TCL_LIMIT_COMMANDS, childInterp, (scriptLen > 0 ? scriptObj : NULL)); } if (granObj != NULL) { - Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_COMMANDS, gran); + Tcl_LimitSetGranularity(childInterp, TCL_LIMIT_COMMANDS, gran); } if (limitObj != NULL) { if (limitLen > 0) { - Tcl_LimitSetCommands(slaveInterp, limit); - Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_COMMANDS); + Tcl_LimitSetCommands(childInterp, limit); + Tcl_LimitTypeSet(childInterp, TCL_LIMIT_COMMANDS); } else { - Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_COMMANDS); + Tcl_LimitTypeReset(childInterp, TCL_LIMIT_COMMANDS); } } return TCL_OK; @@ -4629,7 +4643,7 @@ SlaveCommandLimitCmd( /* *---------------------------------------------------------------------- * - * SlaveTimeLimitCmd -- + * ChildTimeLimitCmd -- * * Implementation of the [interp limit $i time] and [$i limit time] * subcommands. See the interp manual page for a full description. @@ -4644,9 +4658,9 @@ SlaveCommandLimitCmd( */ static int -SlaveTimeLimitCmd( +ChildTimeLimitCmd( Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Interp *slaveInterp, /* Interpreter being adjusted. */ + Tcl_Interp *childInterp, /* Interpreter being adjusted. */ int consumedObjc, /* Number of args already parsed. */ int objc, /* Total number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -4670,7 +4684,7 @@ SlaveTimeLimitCmd( * avoid. [Bug 3398794] */ - if (interp == slaveInterp) { + if (interp == childInterp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "limits on current interpreter inaccessible", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); @@ -4681,7 +4695,7 @@ SlaveTimeLimitCmd( Tcl_Obj *dictPtr; TclNewObj(dictPtr); - key.interp = slaveInterp; + key.interp = childInterp; key.type = TCL_LIMIT_TIME; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { @@ -4700,13 +4714,13 @@ SlaveTimeLimitCmd( Tcl_NewStringObj(options[0], -1), empty); } Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), - Tcl_NewWideIntObj(Tcl_LimitGetGranularity(slaveInterp, + Tcl_NewWideIntObj(Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_TIME))); - if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { + if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) { Tcl_Time limitMoment; - Tcl_LimitGetTime(slaveInterp, &limitMoment); + Tcl_LimitGetTime(childInterp, &limitMoment); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), Tcl_NewWideIntObj(limitMoment.usec/1000)); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[3], -1), @@ -4729,7 +4743,7 @@ SlaveTimeLimitCmd( } switch ((enum Options) index) { case OPT_CMD: - key.interp = slaveInterp; + key.interp = childInterp; key.type = TCL_LIMIT_TIME; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { @@ -4741,22 +4755,22 @@ SlaveTimeLimitCmd( break; case OPT_GRAN: Tcl_SetObjResult(interp, Tcl_NewWideIntObj( - Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_TIME))); + Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_TIME))); break; case OPT_MILLI: - if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { + if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) { Tcl_Time limitMoment; - Tcl_LimitGetTime(slaveInterp, &limitMoment); + Tcl_LimitGetTime(childInterp, &limitMoment); Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limitMoment.usec/1000)); } break; case OPT_SEC: - if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { + if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) { Tcl_Time limitMoment; - Tcl_LimitGetTime(slaveInterp, &limitMoment); + Tcl_LimitGetTime(childInterp, &limitMoment); Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limitMoment.sec)); } break; @@ -4773,7 +4787,7 @@ SlaveTimeLimitCmd( Tcl_Time limitMoment; int tmp; - Tcl_LimitGetTime(slaveInterp, &limitMoment); + Tcl_LimitGetTime(childInterp, &limitMoment); for (i=consumedObjc ; i<objc ; i+=2) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { @@ -4870,18 +4884,18 @@ SlaveTimeLimitCmd( limitMoment.sec += limitMoment.usec / 1000000; limitMoment.usec %= 1000000; - Tcl_LimitSetTime(slaveInterp, &limitMoment); - Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_TIME); + Tcl_LimitSetTime(childInterp, &limitMoment); + Tcl_LimitTypeSet(childInterp, TCL_LIMIT_TIME); } else { - Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_TIME); + Tcl_LimitTypeReset(childInterp, TCL_LIMIT_TIME); } } if (scriptObj != NULL) { - SetScriptLimitCallback(interp, TCL_LIMIT_TIME, slaveInterp, + SetScriptLimitCallback(interp, TCL_LIMIT_TIME, childInterp, (scriptLen > 0 ? scriptObj : NULL)); } if (granObj != NULL) { - Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_TIME, gran); + Tcl_LimitSetGranularity(childInterp, TCL_LIMIT_TIME, gran); } return TCL_OK; } diff --git a/generic/tclLink.c b/generic/tclLink.c index c763218..13bf6c4 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -1303,13 +1303,13 @@ ObjValue( return resultObj; } linkPtr->lastValue.i = LinkedVar(int); - return Tcl_NewIntObj(linkPtr->lastValue.i); + return Tcl_NewWideIntObj(linkPtr->lastValue.i); case TCL_LINK_WIDE_INT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.wPtr[i]); + TclNewIntObj(objv[i], linkPtr->lastValue.wPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1355,7 +1355,7 @@ ObjValue( return resultObj; } linkPtr->lastValue.c = LinkedVar(char); - return Tcl_NewIntObj(linkPtr->lastValue.c); + return Tcl_NewWideIntObj(linkPtr->lastValue.c); case TCL_LINK_UCHAR: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); @@ -1368,7 +1368,7 @@ ObjValue( return resultObj; } linkPtr->lastValue.uc = LinkedVar(unsigned char); - return Tcl_NewIntObj(linkPtr->lastValue.uc); + return Tcl_NewWideIntObj(linkPtr->lastValue.uc); case TCL_LINK_SHORT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); @@ -1381,7 +1381,7 @@ ObjValue( return resultObj; } linkPtr->lastValue.s = LinkedVar(short); - return Tcl_NewIntObj(linkPtr->lastValue.s); + return Tcl_NewWideIntObj(linkPtr->lastValue.s); case TCL_LINK_USHORT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); @@ -1394,13 +1394,13 @@ ObjValue( return resultObj; } linkPtr->lastValue.us = LinkedVar(unsigned short); - return Tcl_NewIntObj(linkPtr->lastValue.us); + return Tcl_NewWideIntObj(linkPtr->lastValue.us); case TCL_LINK_UINT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.uiPtr[i]); + TclNewIntObj(objv[i], linkPtr->lastValue.uiPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1414,7 +1414,7 @@ ObjValue( memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.lPtr[i]); + TclNewIntObj(objv[i], linkPtr->lastValue.lPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1427,7 +1427,7 @@ ObjValue( memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.ulPtr[i]); + TclNewIntObj(objv[i], linkPtr->lastValue.ulPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1454,7 +1454,7 @@ ObjValue( memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewWideIntObj((Tcl_WideInt) + TclNewIntObj(objv[i], (Tcl_WideInt) linkPtr->lastValue.uwPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 5a0d45f..332e6aa 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -479,7 +479,9 @@ TclListObjRange( toIdx = listLen-1; } if (fromIdx > toIdx) { - return Tcl_NewObj(); + Tcl_Obj *obj; + TclNewObj(obj); + return obj; } newLen = toIdx - fromIdx + 1; @@ -1379,7 +1381,7 @@ TclLindexFlat( return NULL; } } - listPtr = Tcl_NewObj(); + TclNewObj(listPtr); } else { /* * Extract the pointer to the appropriate element. @@ -1623,7 +1625,7 @@ TclLsetFlat( if (--indexCount) { parentList = subListPtr; if (index == elemCount) { - subListPtr = Tcl_NewObj(); + TclNewObj(subListPtr); } else { subListPtr = elemPtrs[index]; } diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 738f65b..c143d0a 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -115,7 +115,7 @@ static void LoadCleanupProc(ClientData clientData, int Tcl_LoadObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -137,7 +137,7 @@ Tcl_LoadObjCmd( static const char *const options[] = { "-global", "-lazy", "--", NULL }; - enum options { + enum loadOptionsEnum { LOAD_GLOBAL, LOAD_LAZY, LOAD_LAST }; @@ -150,9 +150,9 @@ Tcl_LoadObjCmd( return TCL_ERROR; } ++objv; --objc; - if (LOAD_GLOBAL == (enum options) index) { + if (LOAD_GLOBAL == (enum loadOptionsEnum) index) { flags |= TCL_LOAD_GLOBAL; - } else if (LOAD_LAZY == (enum options) index) { + } else if (LOAD_LAZY == (enum loadOptionsEnum) index) { flags |= TCL_LOAD_LAZY; } else { break; @@ -196,9 +196,9 @@ Tcl_LoadObjCmd( target = interp; if (objc == 4) { - const char *slaveIntName = Tcl_GetString(objv[3]); + const char *childIntName = Tcl_GetString(objv[3]); - target = Tcl_GetSlave(interp, slaveIntName); + target = Tcl_GetChild(interp, childIntName); if (target == NULL) { code = TCL_ERROR; goto done; @@ -542,7 +542,7 @@ Tcl_LoadObjCmd( int Tcl_UnloadObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -559,7 +559,7 @@ Tcl_UnloadObjCmd( static const char *const options[] = { "-nocomplain", "-keeplibrary", "--", NULL }; - enum options { + enum unloadOptionsEnum { UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST }; @@ -584,7 +584,7 @@ Tcl_UnloadObjCmd( break; } } - switch (index) { + switch ((enum unloadOptionsEnum)index) { case UNLOAD_NOCOMPLAIN: /* -nocomplain */ complain = 0; break; @@ -632,9 +632,9 @@ Tcl_UnloadObjCmd( target = interp; if (objc - i == 3) { - const char *slaveIntName = Tcl_GetString(objv[i + 2]); + const char *childIntName = Tcl_GetString(objv[i + 2]); - target = Tcl_GetSlave(interp, slaveIntName); + target = Tcl_GetChild(interp, childIntName); if (target == NULL) { return TCL_ERROR; } @@ -1073,7 +1073,7 @@ TclGetLoadedPackagesEx( Tcl_Obj *resultObj, *pkgDesc[2]; if (targetName == NULL) { - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { @@ -1087,7 +1087,7 @@ TclGetLoadedPackagesEx( return TCL_OK; } - target = Tcl_GetSlave(interp, targetName); + target = Tcl_GetChild(interp, targetName); if (target == NULL) { return TCL_ERROR; } @@ -1119,7 +1119,7 @@ TclGetLoadedPackagesEx( * interpreter. */ - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { pkgPtr = ipPtr->pkgPtr; pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); diff --git a/generic/tclMain.c b/generic/tclMain.c index 4f44685..cc9a829 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -43,7 +43,7 @@ # define _tcscmp strcmp #endif -static inline Tcl_Obj * +static Tcl_Obj * NewNativeObj( TCHAR *string) { @@ -53,7 +53,7 @@ NewNativeObj( Tcl_DStringInit(&ds); Tcl_WCharToUtfDString(string, -1, &ds); #else - Tcl_ExternalToUtfDString(NULL, (char *) string, -1, &ds); + Tcl_ExternalToUtfDString(NULL, (char *)string, -1, &ds); #endif return TclDStringToObj(&ds); } @@ -307,7 +307,7 @@ Tcl_MainEx( is.interp = interp; is.prompt = PROMPT_START; - is.commandPtr = Tcl_NewObj(); + TclNewObj(is.commandPtr); /* * If the application has not already set a startup script, parse the @@ -348,7 +348,7 @@ Tcl_MainEx( argc--; argv++; - Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY); + Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewWideIntObj(argc), TCL_GLOBAL_ONLY); argvPtr = Tcl_NewListObj(0, NULL); while (argc--) { @@ -362,7 +362,7 @@ Tcl_MainEx( is.tty = isatty(0); Tcl_SetVar2Ex(interp, "tcl_interactive", NULL, - Tcl_NewIntObj(!path && is.tty), TCL_GLOBAL_ONLY); + Tcl_NewWideIntObj(!path && is.tty), TCL_GLOBAL_ONLY); /* * Invoke application-specific initialization. @@ -522,7 +522,7 @@ Tcl_MainEx( TCL_EVAL_GLOBAL); is.input = Tcl_GetStdChannel(TCL_STDIN); Tcl_DecrRefCount(is.commandPtr); - is.commandPtr = Tcl_NewObj(); + TclNewObj(is.commandPtr); Tcl_IncrRefCount(is.commandPtr); if (code != TCL_OK) { chan = Tcl_GetStdChannel(TCL_STDERR); @@ -790,7 +790,8 @@ StdinProc( code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL); isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN); Tcl_DecrRefCount(commandPtr); - isPtr->commandPtr = commandPtr = Tcl_NewObj(); + TclNewObj(commandPtr); + isPtr->commandPtr = commandPtr; Tcl_IncrRefCount(commandPtr); if (chan != NULL) { Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, isPtr); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 26dca62..e493db1 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -1770,6 +1770,8 @@ DoImport( TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr, DeleteImportedCmd); dataPtr->realCmdPtr = cmdPtr; + /* corresponding decrement is in DeleteImportedCmd */ + cmdPtr->refCount++; dataPtr->selfPtr = (Command *) importedCmd; dataPtr->selfPtr->compileProc = cmdPtr->compileProc; Tcl_DStringFree(&ds); @@ -2077,6 +2079,7 @@ DeleteImportedCmd( prevPtr->nextPtr = refPtr->nextPtr; } ckfree(refPtr); + TclCleanupCommandMacro(realCmdPtr); ckfree(dataPtr); return; } @@ -3543,9 +3546,10 @@ NamespaceExportCmd( */ if (objc == 1) { - Tcl_Obj *listPtr = Tcl_NewObj(); + Tcl_Obj *listPtr; - (void) Tcl_AppendExportList(interp, NULL, listPtr); + TclNewObj(listPtr); + (void)Tcl_AppendExportList(interp, NULL, listPtr); Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -3888,7 +3892,7 @@ NamespaceOriginCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Command command, origCommand; + Tcl_Command cmd, origCmd; Tcl_Obj *resultPtr; if (objc != 2) { @@ -3896,30 +3900,29 @@ NamespaceOriginCmd( return TCL_ERROR; } - command = Tcl_GetCommandFromObj(interp, objv[1]); - if (command == NULL) { + cmd = Tcl_GetCommandFromObj(interp, objv[1]); + if (cmd == NULL) { + goto namespaceOriginError; + } + origCmd = TclGetOriginalCommand(cmd); + if (origCmd == NULL) { + origCmd = cmd; + } + TclNewObj(resultPtr); + Tcl_GetCommandFullName(interp, origCmd, resultPtr); + if (TclCheckEmptyString(resultPtr) == TCL_EMPTYSTRING_YES ) { + Tcl_DecrRefCount(resultPtr); + namespaceOriginError: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid command name \"%s\"", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", TclGetString(objv[1]), NULL); return TCL_ERROR; } - origCommand = TclGetOriginalCommand(command); - TclNewObj(resultPtr); - if (origCommand == NULL) { - /* - * The specified command isn't an imported command. Return the - * command's name qualified by the full name of the namespace it was - * defined in. - */ - - Tcl_GetCommandFullName(interp, command, resultPtr); - } else { - Tcl_GetCommandFullName(interp, origCommand, resultPtr); - } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } + /* *---------------------------------------------------------------------- @@ -4022,8 +4025,9 @@ NamespacePathCmd( */ if (objc == 1) { - Tcl_Obj *resultObj = Tcl_NewObj(); + Tcl_Obj *resultObj; + TclNewObj(resultObj); for (i=0 ; i<nsPtr->commandPathLength ; i++) { if (nsPtr->commandPathArray[i].nsPtr != NULL) { Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj( @@ -5016,7 +5020,7 @@ TclLogCommandInfo( */ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj( + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewWideIntObj( iPtr->framePtr->level - iPtr->varFramePtr->level)); } else if (iPtr->framePtr != iPtr->rootFramePtr) { /* diff --git a/generic/tclOO.c b/generic/tclOO.c index 322daff..b60ab1f 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -133,7 +133,7 @@ static const Tcl_MethodType classConstructor = { }; /* - * Scripted parts of TclOO. First, the master script (cannot be outside this + * Scripted parts of TclOO. First, the main script (cannot be outside this * file). */ @@ -258,7 +258,7 @@ TclOOInit( } return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL, - (ClientData) &tclOOStubs); + (void *) &tclOOStubs); } /* @@ -566,7 +566,7 @@ DeletedHelpersNamespace( static void KillFoundation( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp) /* The interpreter containing the OO system * foundation. */ { @@ -1177,7 +1177,7 @@ ObjectNamespaceDeleted( * freed memory. */ - if (((Command *) oPtr->command)->flags && CMD_IS_DELETED) { + if (((Command *) oPtr->command)->flags && CMD_DYING) { /* * Something has already started the command deletion process. We can * go ahead and clean up the the namespace, @@ -3035,7 +3035,7 @@ TclOOObjectName( if (oPtr->cachedNameObj) { return oPtr->cachedNameObj; } - namePtr = Tcl_NewObj(); + TclNewObj(namePtr); Tcl_GetCommandFullName(interp, oPtr->command, namePtr); Tcl_IncrRefCount(namePtr); oPtr->cachedNameObj = namePtr; diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index b866c2c..19f68fc 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -831,7 +831,7 @@ TclOO_Object_VarName( * (including traversing variable links), convert back to a name. */ - varNamePtr = Tcl_NewObj(); + TclNewObj(varNamePtr); if (aryVar != NULL) { Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr); diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 76cf4ed..e1d88ec 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1050,8 +1050,8 @@ MagicDefinitionInvoke( * comments above for why these contortions are necessary. */ - objPtr = Tcl_NewObj(); - obj2Ptr = Tcl_NewObj(); + TclNewObj(objPtr); + TclNewObj(obj2Ptr); cmd = FindCommand(interp, objv[cmdIndex], nsPtr); if (cmd == NULL) { /* @@ -2338,7 +2338,7 @@ ClassFilterGet( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(filterObj, oPtr->classPtr->filters) { Tcl_ListObjAppendElement(NULL, resultObj, filterObj); } @@ -2419,7 +2419,7 @@ ClassMixinGet( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(mixinPtr, oPtr->classPtr->mixins) { Tcl_ListObjAppendElement(NULL, resultObj, TclOOObjectName(interp, mixinPtr->thisPtr)); @@ -2525,7 +2525,7 @@ ClassSuperGet( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(superPtr, oPtr->classPtr->superclasses) { Tcl_ListObjAppendElement(NULL, resultObj, TclOOObjectName(interp, superPtr->thisPtr)); @@ -2691,7 +2691,7 @@ ClassVarsGet( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); if (IsPrivateDefine(interp)) { PrivateVariableMapping *privatePtr; @@ -2800,7 +2800,7 @@ ObjFilterGet( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(filterObj, oPtr->filters) { Tcl_ListObjAppendElement(NULL, resultObj, filterObj); } @@ -2869,7 +2869,7 @@ ObjMixinGet( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(mixinPtr, oPtr->mixins) { if (mixinPtr) { Tcl_ListObjAppendElement(NULL, resultObj, @@ -2954,7 +2954,7 @@ ObjVarsGet( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); if (IsPrivateDefine(interp)) { PrivateVariableMapping *privatePtr; diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 3758d55..c9e136c 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -114,7 +114,7 @@ TclOOInitInfo( TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds); /* - * Install into the master [info] ensemble. + * Install into the [info] ensemble. */ infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); @@ -171,7 +171,7 @@ GetClassFromObj( static int InfoObjectClassCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -206,11 +206,11 @@ InfoObjectClassCmd( continue; } if (TclOOIsReachable(o2clsPtr, mixinPtr)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); return TCL_OK; } } - Tcl_SetObjResult(interp, Tcl_NewIntObj( + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( TclOOIsReachable(o2clsPtr, oPtr->selfCls))); return TCL_OK; } @@ -228,7 +228,7 @@ InfoObjectClassCmd( static int InfoObjectDefnCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -270,13 +270,13 @@ InfoObjectDefnCmd( return TCL_ERROR; } - resultObjs[0] = Tcl_NewObj(); + TclNewObj(resultObjs[0]); for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { Tcl_Obj *argObj; - argObj = Tcl_NewObj(); + TclNewObj(argObj); Tcl_ListObjAppendElement(NULL, argObj, Tcl_NewStringObj(localPtr->name, -1)); if (localPtr->defValuePtr != NULL) { @@ -302,7 +302,7 @@ InfoObjectDefnCmd( static int InfoObjectFiltersCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -320,7 +320,7 @@ InfoObjectFiltersCmd( if (oPtr == NULL) { return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(filterObj, oPtr->filters) { Tcl_ListObjAppendElement(NULL, resultObj, filterObj); @@ -341,7 +341,7 @@ InfoObjectFiltersCmd( static int InfoObjectForwardCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -398,7 +398,7 @@ InfoObjectForwardCmd( static int InfoObjectIsACmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -517,7 +517,7 @@ InfoObjectIsACmd( static int InfoObjectMethodsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -601,7 +601,7 @@ InfoObjectMethodsCmd( } } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); if (recurse) { const char **names; int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag, @@ -637,7 +637,7 @@ InfoObjectMethodsCmd( static int InfoObjectMethodTypeCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -694,7 +694,7 @@ InfoObjectMethodTypeCmd( static int InfoObjectMixinsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -713,7 +713,7 @@ InfoObjectMixinsCmd( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(mixinPtr, oPtr->mixins) { if (!mixinPtr) { continue; @@ -737,7 +737,7 @@ InfoObjectMixinsCmd( static int InfoObjectIdCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -753,7 +753,7 @@ InfoObjectIdCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->creationEpoch)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(oPtr->creationEpoch)); return TCL_OK; } @@ -769,7 +769,7 @@ InfoObjectIdCmd( static int InfoObjectNsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -802,7 +802,7 @@ InfoObjectNsCmd( static int InfoObjectVariablesCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -826,7 +826,7 @@ InfoObjectVariablesCmd( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); if (isPrivate) { PrivateVariableMapping *privatePtr; @@ -856,7 +856,7 @@ InfoObjectVariablesCmd( static int InfoObjectVarsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -878,7 +878,7 @@ InfoObjectVarsCmd( if (objc == 3) { pattern = TclGetString(objv[2]); } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); /* * Extract the information we need from the object's namespace's table of @@ -917,7 +917,7 @@ InfoObjectVarsCmd( static int InfoClassConstrCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -946,13 +946,13 @@ InfoClassConstrCmd( return TCL_ERROR; } - resultObjs[0] = Tcl_NewObj(); + TclNewObj(resultObjs[0]); for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { Tcl_Obj *argObj; - argObj = Tcl_NewObj(); + TclNewObj(argObj); Tcl_ListObjAppendElement(NULL, argObj, Tcl_NewStringObj(localPtr->name, -1)); if (localPtr->defValuePtr != NULL) { @@ -978,7 +978,7 @@ InfoClassConstrCmd( static int InfoClassDefnCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1014,13 +1014,13 @@ InfoClassDefnCmd( return TCL_ERROR; } - resultObjs[0] = Tcl_NewObj(); + TclNewObj(resultObjs[0]); for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { Tcl_Obj *argObj; - argObj = Tcl_NewObj(); + TclNewObj(argObj); Tcl_ListObjAppendElement(NULL, argObj, Tcl_NewStringObj(localPtr->name, -1)); if (localPtr->defValuePtr != NULL) { @@ -1046,7 +1046,7 @@ InfoClassDefnCmd( static int InfoClassDefnNsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1096,7 +1096,7 @@ InfoClassDefnNsCmd( static int InfoClassDestrCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1140,7 +1140,7 @@ InfoClassDestrCmd( static int InfoClassFiltersCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1158,7 +1158,7 @@ InfoClassFiltersCmd( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(filterObj, clsPtr->filters) { Tcl_ListObjAppendElement(NULL, resultObj, filterObj); } @@ -1178,7 +1178,7 @@ InfoClassFiltersCmd( static int InfoClassForwardCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1229,7 +1229,7 @@ InfoClassForwardCmd( static int InfoClassInstancesCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1252,7 +1252,7 @@ InfoClassInstancesCmd( pattern = TclGetString(objv[2]); } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(oPtr, clsPtr->instances) { Tcl_Obj *tmpObj = TclOOObjectName(interp, oPtr); @@ -1277,7 +1277,7 @@ InfoClassInstancesCmd( static int InfoClassMethodsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1356,7 +1356,7 @@ InfoClassMethodsCmd( } } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); if (recurse) { const char **names; int i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names); @@ -1393,7 +1393,7 @@ InfoClassMethodsCmd( static int InfoClassMethodTypeCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1445,7 +1445,7 @@ InfoClassMethodTypeCmd( static int InfoClassMixinsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1463,7 +1463,7 @@ InfoClassMixinsCmd( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(mixinPtr, clsPtr->mixins) { if (!mixinPtr) { continue; @@ -1487,7 +1487,7 @@ InfoClassMixinsCmd( static int InfoClassSubsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1509,7 +1509,7 @@ InfoClassSubsCmd( pattern = TclGetString(objv[2]); } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(subclassPtr, clsPtr->subclasses) { Tcl_Obj *tmpObj = TclOOObjectName(interp, subclassPtr->thisPtr); @@ -1542,7 +1542,7 @@ InfoClassSubsCmd( static int InfoClassSupersCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1560,7 +1560,7 @@ InfoClassSupersCmd( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); FOREACH(superPtr, clsPtr->superclasses) { Tcl_ListObjAppendElement(NULL, resultObj, TclOOObjectName(interp, superPtr->thisPtr)); @@ -1581,7 +1581,7 @@ InfoClassSupersCmd( static int InfoClassVariablesCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1605,7 +1605,7 @@ InfoClassVariablesCmd( return TCL_ERROR; } - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); if (isPrivate) { PrivateVariableMapping *privatePtr; @@ -1635,7 +1635,7 @@ InfoClassVariablesCmd( static int InfoObjectCallCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1681,7 +1681,7 @@ InfoObjectCallCmd( static int InfoClassCallCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index db4b7f1..007cbfd 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -329,7 +329,7 @@ typedef struct Class { */ typedef struct ThreadLocalData { - int nsCount; /* Master epoch counter is used for keeping + int nsCount; /* Epoch counter is used for keeping * the values used in Tcl_Obj internal * representations sane. Must be thread-local * because Tcl_Objs can cross interpreter @@ -341,7 +341,7 @@ typedef struct Foundation { Tcl_Interp *interp; Class *objectCls; /* The root of the object system. */ Class *classCls; /* The class of all classes. */ - Tcl_Namespace *ooNs; /* Master ::oo namespace. */ + Tcl_Namespace *ooNs; /* ::oo namespace. */ Tcl_Namespace *defineNs; /* Namespace containing special commands for * manipulating objects and classes. The * "oo::define" command acts as a special kind diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index b1b3d8e..f65462e 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -394,7 +394,7 @@ TclOONewProcMethod( if (argsObj == NULL) { argsLen = -1; - argsObj = Tcl_NewObj(); + TclNewObj(argsObj); Tcl_IncrRefCount(argsObj); procName = "<destructor>"; } else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) { @@ -1315,12 +1315,13 @@ CloneProcedureMethod( * Copy the argument list. */ - argsObj = Tcl_NewObj(); + TclNewObj(argsObj); for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { - Tcl_Obj *argObj = Tcl_NewObj(); + Tcl_Obj *argObj; + TclNewObj(argObj); Tcl_ListObjAppendElement(NULL, argObj, Tcl_NewStringObj(localPtr->name, -1)); if (localPtr->defValuePtr != NULL) { diff --git a/generic/tclObj.c b/generic/tclObj.c index dbe6686..6e17141 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -145,12 +145,12 @@ typedef struct PendingObjData { #define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--) #define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0) #define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) -#define PushObjToDelete(contextPtr,objPtr) \ +#define PushObjToDelete(contextPtr,objPtr) \ /* The string rep is already invalidated so we can use the bytes value \ * for our pointer chain: push onto the head of the stack. */ \ (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \ (contextPtr)->deletionStack = (objPtr) -#define PopObjToDelete(contextPtr,objPtrVar) \ +#define PopObjToDelete(contextPtr,objPtrVar) \ (objPtrVar) = (contextPtr)->deletionStack; \ (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes @@ -161,14 +161,14 @@ typedef struct PendingObjData { static PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *const contextPtr = &pendingObjData -#elif HAVE_FAST_TSD +#elif defined(HAVE_FAST_TSD) static __thread PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *const contextPtr = &pendingObjData #else static Tcl_ThreadDataKey pendingObjDataKey; #define ObjInitDeletionContext(contextPtr) \ - PendingObjData *const contextPtr = \ + PendingObjData *const contextPtr = \ (PendingObjData *)Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) #endif @@ -177,15 +177,15 @@ static Tcl_ThreadDataKey pendingObjDataKey; */ #define PACK_BIGNUM(bignum, objPtr) \ - if ((bignum).used > 0x7FFF) { \ - mp_int *temp = (mp_int *) ckalloc(sizeof(mp_int)); \ + if ((bignum).used > 0x7FFF) { \ + mp_int *temp = (mp_int *)ckalloc(sizeof(mp_int)); \ *temp = bignum; \ - (objPtr)->internalRep.twoPtrValue.ptr1 = temp; \ - (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \ + (objPtr)->internalRep.twoPtrValue.ptr1 = temp; \ + (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \ } else if (((bignum).alloc <= 0x7FFF) || (mp_shrink(&(bignum))) == MP_OKAY) { \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (bignum).dp; \ - (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \ - | ((bignum).alloc << 15) | ((bignum).used)); \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(bignum).dp; \ + (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(((bignum).sign << 30) \ + | ((bignum).alloc << 15) | ((bignum).used)); \ } /* @@ -567,7 +567,7 @@ TclContinuationsEnter( ThreadSpecificData *tsdPtr = TclGetContLineTable(); Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry); - ContLineLoc *clLocPtr = (ContLineLoc *)ckalloc(sizeof(ContLineLoc) + num*sizeof(int)); + ContLineLoc *clLocPtr = (ContLineLoc *)ckalloc(offsetof(ContLineLoc, loc) + (num + 1) *sizeof(int)); if (!newEntry) { /* @@ -4667,7 +4667,7 @@ SetCmdNameFromAny( * report the failure to find the command as an error. */ - if (cmdPtr == NULL) { + if (cmdPtr == NULL || !TclRoutineHasName(cmdPtr)) { return TCL_ERROR; } diff --git a/generic/tclParse.c b/generic/tclParse.c index 7f32cfa..daad31d 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -119,7 +119,7 @@ const char tclCharTypeTable[] = { * Prototypes for local functions defined in this file: */ -static inline int CommandComplete(const char *script, int numBytes); +static int CommandComplete(const char *script, int numBytes); static int ParseComment(const char *src, int numBytes, Tcl_Parse *parsePtr); static int ParseTokens(const char *src, int numBytes, int mask, @@ -2104,7 +2104,7 @@ TclSubstTokens( * command, which is refered to by 'script'. * The 'clNextOuter' refers to the current * entry in the table of continuation lines in - * this "master script", and the character + * this "main script", and the character * offsets are relative to the 'outerScript' * as well. * @@ -2396,7 +2396,7 @@ TclSubstTokens( *---------------------------------------------------------------------- */ -static inline int +static int CommandComplete( const char *script, /* Script to check. */ int numBytes) /* Number of bytes in script. */ diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 32b2961..8b1f199 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -722,7 +722,7 @@ TclPathPart( (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE))) { Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &resultPtr); } else { - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); } } else { /* @@ -760,7 +760,7 @@ GetExtension( tail = TclGetString(pathPtr); extension = TclGetExtension(tail); if (extension == NULL) { - ret = Tcl_NewObj(); + TclNewObj(ret); } else { ret = Tcl_NewStringObj(extension, -1); } @@ -1036,7 +1036,7 @@ TclJoinPath( noQuickReturn: if (res == NULL) { - res = Tcl_NewObj(); + TclNewObj(res); } ptr = TclGetStringFromObj(res, &length); @@ -1272,7 +1272,7 @@ TclNewFSPathObj( return pathPtr; } - pathPtr = Tcl_NewObj(); + TclNewObj(pathPtr); fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath)); /* diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 8d5c0c7..e9ad4e6 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -334,7 +334,7 @@ TclCleanupChildren( Tcl_Obj *objPtr; Tcl_Seek(errorChan, 0, SEEK_SET); - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); count = Tcl_ReadChars(errorChan, objPtr, -1, 0); if (count < 0) { result = TCL_ERROR; diff --git a/generic/tclPkg.c b/generic/tclPkg.c index bdd9a86..89fb0c4 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -285,7 +285,7 @@ TclPkgFileSeen( Tcl_Obj *list; if (isNew) { - list = Tcl_NewObj(); + TclNewObj(list); Tcl_SetHashValue(entry, list); Tcl_IncrRefCount(list); } else { @@ -1073,7 +1073,7 @@ TclNRPackageObjCmd( "present", "provide", "require", "unknown", "vcompare", "versions", "vsatisfies", NULL }; - enum pkgOptions { + enum pkgOptionsEnum { PKG_FILES, PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS, PKG_VSATISFIES @@ -1099,7 +1099,7 @@ TclNRPackageObjCmd( &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum pkgOptions) optionIndex) { + switch ((enum pkgOptionsEnum) optionIndex) { case PKG_FILES: { PkgFiles *pkgFiles; @@ -1241,7 +1241,7 @@ TclNRPackageObjCmd( } else { Tcl_Obj *resultObj; - resultObj = Tcl_NewObj(); + TclNewObj(resultObj); tablePtr = &iPtr->packageTable; for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { @@ -1368,9 +1368,9 @@ TclNRPackageObjCmd( newObjvPtr, NULL); return TCL_OK; } else { - int i, newobjc = objc-3; Tcl_Obj *const *newobjv = objv + 3; + newobjc = objc - 3; if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { return TCL_ERROR; } @@ -1481,7 +1481,7 @@ TclNRPackageObjCmd( */ Tcl_SetObjResult(interp, - Tcl_NewIntObj(CompareVersions(iva, ivb, NULL))); + Tcl_NewWideIntObj(CompareVersions(iva, ivb, NULL))); ckfree(iva); ckfree(ivb); break; @@ -1490,8 +1490,9 @@ TclNRPackageObjCmd( Tcl_WrongNumArgs(interp, 2, objv, "package"); return TCL_ERROR; } else { - Tcl_Obj *resultObj = Tcl_NewObj(); + Tcl_Obj *resultObj; + TclNewObj(resultObj); argv2 = TclGetString(objv[2]); hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr != NULL) { diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c index 96b6962..12df68e 100644 --- a/generic/tclPkgConfig.c +++ b/generic/tclPkgConfig.c @@ -35,6 +35,10 @@ #include "tclInt.h" +#ifndef TCL_CFGVAL_ENCODING +# define TCL_CFGVAL_ENCODING "utf-8" +#endif + /* * Use C preprocessor statements to define the various values for the embedded * configuration information. diff --git a/generic/tclProc.c b/generic/tclProc.c index 0d67c37..20af5fe 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -632,7 +632,8 @@ TclCreateProc( * local variables for the argument. */ - localPtr = (CompiledLocal *)ckalloc(offsetof(CompiledLocal, name) + fieldValues[0]->length +1); + localPtr = (CompiledLocal *)ckalloc( + offsetof(CompiledLocal, name) + fieldValues[0]->length + 1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -909,9 +910,28 @@ TclNRUplevelObjCmd( Tcl_Obj *objPtr; if (objc < 2) { + /* to do + * simplify things by interpreting the argument as a command when there + * is only one argument. This requires a TIP since currently a single + * argument is interpreted as a level indicator if possible. + */ uplevelSyntax: Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); return TCL_ERROR; + } else if (!TclHasStringRep(objv[1]) && objc == 2) { + int status ,llength; + status = Tcl_ListObjLength(interp, objv[1], &llength); + if (status == TCL_OK && llength > 1) { + /* the first argument can't interpreted as a level. Avoid + * generating a string representation of the script. */ + result = TclGetFrame(interp, "1", &framePtr); + if (result == -1) { + return TCL_ERROR; + } + objc -= 1; + objv += 1; + goto havelevel; + } } /* @@ -928,6 +948,8 @@ TclNRUplevelObjCmd( } objv += result + 1; + havelevel: + /* * Modify the interpreter state to execute in the given frame. */ @@ -1313,8 +1335,8 @@ InitLocalCache( * for future calls. */ - localCachePtr = (LocalCache *)ckalloc(sizeof(LocalCache) - + (localCt - 1) * sizeof(Tcl_Obj *) + localCachePtr = (LocalCache *)ckalloc(offsetof(LocalCache, varName0) + + localCt * sizeof(Tcl_Obj *) + numArgs * sizeof(Var)); namePtr = &localCachePtr->varName0; diff --git a/generic/tclProcess.c b/generic/tclProcess.c index c0f21e3..7bd5e1a 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -222,7 +222,7 @@ WaitProcessStatus( * Get process status. */ - if (pid == (Tcl_Pid) -1) { + if (pid == (Tcl_Pid)-1) { /* * POSIX errName msg */ @@ -371,7 +371,7 @@ BuildProcessStatusObj( * Normal exit, return TCL_OK. */ - return Tcl_NewIntObj(TCL_OK); + return Tcl_NewWideIntObj(TCL_OK); } /* @@ -427,7 +427,7 @@ ProcessListObjCmd( entry != NULL; entry = Tcl_NextHashEntry(&search)) { info = (ProcessInfo *) Tcl_GetHashValue(entry); Tcl_ListObjAppendElement(interp, list, - Tcl_NewIntObj(info->resolvedPid)); + Tcl_NewWideIntObj(info->resolvedPid)); } Tcl_MutexUnlock(&infoTablesMutex); Tcl_SetObjResult(interp, list); @@ -472,7 +472,7 @@ ProcessStatusObjCmd( static const char *const switches[] = { "-wait", "--", NULL }; - enum switches { + enum switchesEnum { STATUS_WAIT, STATUS_LAST }; @@ -485,7 +485,7 @@ ProcessStatusObjCmd( return TCL_ERROR; } ++objv; --objc; - if (STATUS_WAIT == (enum switches) index) { + if (STATUS_WAIT == (enum switchesEnum) index) { options = 0; } else { break; @@ -523,7 +523,7 @@ ProcessStatusObjCmd( * Add to result. */ - Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + Tcl_DictObjPut(interp, dict, Tcl_NewWideIntObj(info->resolvedPid), BuildProcessStatusObj(info)); } } @@ -573,7 +573,7 @@ ProcessStatusObjCmd( * Add to result. */ - Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + Tcl_DictObjPut(interp, dict, Tcl_NewWideIntObj(info->resolvedPid), BuildProcessStatusObj(info)); } } @@ -834,7 +834,7 @@ TclProcessCreated( * Allocate and initialize info structure. */ - info = (ProcessInfo *) ckalloc(sizeof(ProcessInfo)); + info = (ProcessInfo *)ckalloc(sizeof(ProcessInfo)); InitProcessInfo(info, pid, resolvedPid); /* diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 8b88423..99135d3 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -676,9 +676,9 @@ TclRegAbout( * well and Tcl has other limits that constrain things as well... */ - resultObj = Tcl_NewObj(); - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewWideIntObj((Tcl_WideInt) regexpPtr->re.re_nsub)); + TclNewObj(resultObj); + TclNewIntObj(infoObj, regexpPtr->re.re_nsub); + Tcl_ListObjAppendElement(NULL, resultObj, infoObj); /* * Now append a list of all the bit-flags set for the RE. diff --git a/generic/tclResult.c b/generic/tclResult.c index baecf46..1fb2ad0 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -248,7 +248,7 @@ Tcl_SaveResult( */ statePtr->objResultPtr = iPtr->objResultPtr; - iPtr->objResultPtr = Tcl_NewObj(); + TclNewObj(iPtr->objResultPtr); Tcl_IncrRefCount(iPtr->objResultPtr); /* @@ -841,19 +841,19 @@ SetupAppendBuffer( totalSpace = newSpace + iPtr->appendUsed; if (totalSpace >= iPtr->appendAvl) { - char *newSpace; + char *newSpacePtr; if (totalSpace < 100) { totalSpace = 200; } else { totalSpace *= 2; } - newSpace = (char *)ckalloc(totalSpace); - strcpy(newSpace, iPtr->result); + newSpacePtr = (char *)ckalloc(totalSpace); + strcpy(newSpacePtr, iPtr->result); if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); } - iPtr->appendResult = newSpace; + iPtr->appendResult = newSpacePtr; iPtr->appendAvl = totalSpace; } else if (iPtr->result != iPtr->appendResult) { strcpy(iPtr->appendResult, iPtr->result); @@ -1036,13 +1036,14 @@ Tcl_SetErrorCodeVA( Tcl_Interp *interp, /* Interpreter in which to set errorCode */ va_list argList) /* Variable argument list. */ { - Tcl_Obj *errorObj = Tcl_NewObj(); + Tcl_Obj *errorObj; /* * Scan through the arguments one at a time, appending them to the * errorCode field as list elements. */ + TclNewObj(errorObj); while (1) { char *elem = va_arg(argList, char *); @@ -1395,9 +1396,10 @@ TclMergeReturnOptions( int code = TCL_OK; int level = 1; Tcl_Obj *valuePtr; - Tcl_Obj *returnOpts = Tcl_NewObj(); + Tcl_Obj *returnOpts; Tcl_Obj **keys = GetKeys(); + TclNewObj(returnOpts); for (; objc > 1; objv += 2, objc -= 2) { const char *opt = TclGetString(objv[0]); const char *compare = TclGetString(keys[KEY_OPTIONS]); @@ -1591,19 +1593,19 @@ Tcl_GetReturnOptions( if (iPtr->returnOpts) { options = Tcl_DuplicateObj(iPtr->returnOpts); } else { - options = Tcl_NewObj(); + TclNewObj(options); } if (result == TCL_RETURN) { Tcl_DictObjPut(NULL, options, keys[KEY_CODE], - Tcl_NewIntObj(iPtr->returnCode)); + Tcl_NewWideIntObj(iPtr->returnCode)); Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL], - Tcl_NewIntObj(iPtr->returnLevel)); + Tcl_NewWideIntObj(iPtr->returnLevel)); } else { Tcl_DictObjPut(NULL, options, keys[KEY_CODE], - Tcl_NewIntObj(result)); + Tcl_NewWideIntObj(result)); Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL], - Tcl_NewIntObj(0)); + Tcl_NewWideIntObj(0)); } if (result == TCL_ERROR) { @@ -1616,7 +1618,7 @@ Tcl_GetReturnOptions( if (iPtr->errorInfo) { Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo); Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE], - Tcl_NewIntObj(iPtr->errorLine)); + Tcl_NewWideIntObj(iPtr->errorLine)); } return options; } diff --git a/generic/tclScan.c b/generic/tclScan.c index 4d86382..67fe6f3 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -716,7 +716,7 @@ Tcl_ScanObjCmd( switch (ch) { case 'n': if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewWideIntObj(string - baseString); + TclNewIntObj(objPtr, string - baseString); Tcl_IncrRefCount(objPtr); CLANG_ASSERT(objs); objs[objIndex++] = objPtr; @@ -879,7 +879,7 @@ Tcl_ScanObjCmd( offset = TclUtfToUCS4(string, &i); string += offset; if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewWideIntObj(i); + TclNewIntObj(objPtr, i); Tcl_IncrRefCount(objPtr); CLANG_ASSERT(objs); objs[objIndex++] = objPtr; @@ -890,7 +890,7 @@ Tcl_ScanObjCmd( /* * Scan an unsigned or signed integer. */ - objPtr = Tcl_NewWideIntObj(0); + TclNewIntObj(objPtr, 0); Tcl_IncrRefCount(objPtr); if (width == 0) { width = ~0; @@ -937,16 +937,16 @@ Tcl_ScanObjCmd( } else if (flags & SCAN_BIG) { if (flags & SCAN_UNSIGNED) { mp_int big; - int code = Tcl_GetBignumFromObj(interp, objPtr, &big); + int res = Tcl_GetBignumFromObj(interp, objPtr, &big); - if (code == TCL_OK) { + if (res == TCL_OK) { if (mp_isneg(&big)) { - code = TCL_ERROR; + res = TCL_ERROR; } mp_clear(&big); } - if (code == TCL_ERROR) { + if (res == TCL_ERROR) { if (objs != NULL) { ckfree(objs); } @@ -1068,7 +1068,7 @@ Tcl_ScanObjCmd( * Here no vars were specified, we want a list returned (inline scan) */ - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); for (i = 0; i < totalVars; i++) { if (objs[i] != NULL) { Tcl_ListObjAppendElement(NULL, objPtr, objs[i]); @@ -1089,16 +1089,16 @@ Tcl_ScanObjCmd( if (code == TCL_OK) { if (underflow && (nconversions == 0)) { if (numVars) { - objPtr = Tcl_NewWideIntObj(-1); + TclNewIntObj(objPtr, TCL_INDEX_NONE); } else { if (objPtr) { Tcl_SetListObj(objPtr, 0, NULL); } else { - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); } } } else if (numVars) { - objPtr = Tcl_NewWideIntObj(result); + TclNewIntObj(objPtr, result); } Tcl_SetObjResult(interp, objPtr); } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 81c5c92..03aceaf 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2133,7 +2133,7 @@ Tcl_AppendFormatToObj( if (l == (long) 0) gotHash = 0; } - segment = Tcl_NewObj(); + TclNewObj(segment); allocSegment = 1; segmentLimit = INT_MAX; Tcl_IncrRefCount(segment); @@ -2178,15 +2178,15 @@ Tcl_AppendFormatToObj( const char *bytes; if (useShort) { - pure = Tcl_NewWideIntObj(s); + TclNewIntObj(pure, s); #ifndef TCL_WIDE_INT_IS_LONG } else if (useWide) { - pure = Tcl_NewWideIntObj(w); + TclNewIntObj(pure, w); #endif } else if (useBig) { pure = Tcl_NewBignumObj(&big); } else { - pure = Tcl_NewWideIntObj(l); + TclNewIntObj(pure, l); } Tcl_IncrRefCount(pure); bytes = TclGetStringFromObj(pure, &length); @@ -2308,7 +2308,7 @@ Tcl_AppendFormatToObj( if (numDigits == 0) { numDigits = 1; } - pure = Tcl_NewObj(); + TclNewObj(pure); Tcl_SetObjLength(pure, (int) numDigits); bytes = TclGetString(pure); toAppend = length = (int) numDigits; @@ -2429,7 +2429,7 @@ Tcl_AppendFormatToObj( *p++ = (char) ch; *p = '\0'; - segment = Tcl_NewObj(); + TclNewObj(segment); allocSegment = 1; if (!Tcl_AttemptSetObjLength(segment, length)) { msg = overflow; @@ -2443,10 +2443,10 @@ Tcl_AppendFormatToObj( goto errorMsg; } if (ch == 'A') { - char *p = TclGetString(segment) + 1; - *p = 'x'; - p = strchr(p, 'P'); - if (p) *p = 'p'; + char *q = TclGetString(segment) + 1; + *q = 'x'; + q = strchr(q, 'P'); + if (q) *q = 'p'; } break; } @@ -2543,8 +2543,9 @@ Tcl_Format( Tcl_Obj *const objv[]) { int result; - Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_Obj *objPtr; + TclNewObj(objPtr); result = Tcl_AppendFormatToObj(interp, objPtr, format, objc, objv); if (result != TCL_OK) { Tcl_DecrRefCount(objPtr); @@ -2572,9 +2573,10 @@ AppendPrintfToObjVA( va_list argList) { int code, objc; - Tcl_Obj **objv, *list = Tcl_NewObj(); + Tcl_Obj **objv, *list; const char *p; + TclNewObj(list); p = format; Tcl_IncrRefCount(list); while (*p != '\0') { @@ -2788,8 +2790,9 @@ Tcl_ObjPrintf( ...) { va_list argList; - Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_Obj *objPtr; + TclNewObj(objPtr); va_start(argList, format); AppendPrintfToObjVA(objPtr, format, argList); va_end(argList); @@ -3314,7 +3317,7 @@ TclStringCat( /* assert ( length > start ) */ TclFreeIntRep(objResultPtr); } else { - objResultPtr = Tcl_NewObj(); /* PANIC? */ + TclNewObj(objResultPtr); /* PANIC? */ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { Tcl_DecrRefCount(objResultPtr); if (interp) { @@ -3410,7 +3413,7 @@ TclStringCmp( if (nocase) { s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len); s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len); - memCmpFn = (memCmpFn_t)Tcl_UniCharNcasecmp; + memCmpFn = (memCmpFn_t)(void *)Tcl_UniCharNcasecmp; } else { s1len = Tcl_GetCharLength(value1Ptr); s2len = Tcl_GetCharLength(value2Ptr); @@ -3435,7 +3438,7 @@ TclStringCmp( s1len *= sizeof(Tcl_UniChar); s2len *= sizeof(Tcl_UniChar); } else { - memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp; + memCmpFn = (memCmpFn_t)(void *)Tcl_UniCharNcmp; } } } @@ -3493,11 +3496,11 @@ TclStringCmp( */ if ((reqlength < 0) && !nocase) { - memCmpFn = (memCmpFn_t) TclpUtfNcmp2; + memCmpFn = (memCmpFn_t)(void *)TclpUtfNcmp2; } else { s1len = Tcl_NumUtfChars(s1, s1len); s2len = Tcl_NumUtfChars(s2, s2len); - memCmpFn = (memCmpFn_t) + memCmpFn = (memCmpFn_t)(void *) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); } } @@ -3561,7 +3564,7 @@ TclStringFirst( int lh, ln = Tcl_GetCharLength(needle); Tcl_Obj *result; int value = -1; - Tcl_UniChar *check, *end, *uh, *un; + Tcl_UniChar *checkStr, *endStr, *uh, *un; if (start < 0) { start = 0; @@ -3627,12 +3630,12 @@ TclStringFirst( /* Don't start the loop if there cannot be a valid answer */ goto firstEnd; } - end = uh + lh; + endStr = uh + lh; - for (check = uh + start; check + ln <= end; check++) { - if ((*check == *un) && (0 == - memcmp(check + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) { - value = (check - uh); + for (checkStr = uh + start; checkStr + ln <= endStr; checkStr++) { + if ((*checkStr == *un) && (0 == + memcmp(checkStr + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) { + value = (checkStr - uh); goto firstEnd; } } @@ -3668,7 +3671,7 @@ TclStringLast( int lh, ln = Tcl_GetCharLength(needle); Tcl_Obj *result; int value = -1; - Tcl_UniChar *check, *uh, *un; + Tcl_UniChar *checkStr, *uh, *un; if (ln == 0) { /* @@ -3714,14 +3717,14 @@ TclStringLast( /* Don't start the loop if there cannot be a valid answer */ goto lastEnd; } - check = uh + last + 1 - ln; - while (check >= uh) { - if ((*check == un[0]) - && (0 == memcmp(check+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) { - value = (check - uh); + checkStr = uh + last + 1 - ln; + while (checkStr >= uh) { + if ((*checkStr == un[0]) + && (0 == memcmp(checkStr+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) { + value = (checkStr - uh); goto lastEnd; } - check--; + checkStr--; } lastEnd: TclNewIntObj(result, value); @@ -3830,7 +3833,7 @@ TclStringReverse( char *to, *from = objPtr->bytes; if (!inPlace || Tcl_IsShared(objPtr)) { - objPtr = Tcl_NewObj(); + TclNewObj(objPtr); Tcl_SetObjLength(objPtr, numBytes); } to = objPtr->bytes; diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h index fc5a713..e01ba2d 100644 --- a/generic/tclStringRep.h +++ b/generic/tclStringRep.h @@ -59,15 +59,15 @@ typedef struct { * space allocated for the unicode array. */ int hasUnicode; /* Boolean determining whether the string has * a Unicode representation. */ - Tcl_UniChar unicode[1]; /* The array of Unicode chars. The actual size + Tcl_UniChar unicode[TCLFLEXARRAY]; /* The array of Unicode chars. The actual size * of this field depends on the 'maxChars' * field above. */ } String; #define STRING_MAXCHARS \ - (int)(((size_t)UINT_MAX - sizeof(String))/sizeof(Tcl_UniChar)) + (int)(((size_t)UINT_MAX - 1 - offsetof(String, unicode))/sizeof(Tcl_UniChar)) #define STRING_SIZE(numChars) \ - (sizeof(String) + ((numChars) * sizeof(Tcl_UniChar))) + (offsetof(String, unicode) + ((numChars + 1) * sizeof(Tcl_UniChar))) #define stringCheckLimits(numChars) \ do { \ if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 5411d88..36cb9b5 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -450,7 +450,7 @@ void *TclWinGetTclInstance() int TclpGetPid(Tcl_Pid pid) { - return (int) (size_t) pid; + return (int)(size_t)pid; } #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 @@ -1312,7 +1312,7 @@ const TclStubs tclStubs = { Tcl_CreateInterp, /* 94 */ Tcl_CreateMathFunc, /* 95 */ Tcl_CreateObjCommand, /* 96 */ - Tcl_CreateSlave, /* 97 */ + Tcl_CreateChild, /* 97 */ Tcl_CreateTimerHandler, /* 98 */ Tcl_CreateTrace, /* 99 */ Tcl_DeleteAssocData, /* 100 */ @@ -1379,7 +1379,7 @@ const TclStubs tclStubs = { Tcl_GetErrno, /* 161 */ Tcl_GetHostName, /* 162 */ Tcl_GetInterpPath, /* 163 */ - Tcl_GetMaster, /* 164 */ + Tcl_GetParent, /* 164 */ Tcl_GetNameOfExecutable, /* 165 */ Tcl_GetObjResult, /* 166 */ #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ @@ -1395,7 +1395,7 @@ const TclStubs tclStubs = { Tcl_Gets, /* 169 */ Tcl_GetsObj, /* 170 */ Tcl_GetServiceMode, /* 171 */ - Tcl_GetSlave, /* 172 */ + Tcl_GetChild, /* 172 */ Tcl_GetStdChannel, /* 173 */ Tcl_GetStringResult, /* 174 */ Tcl_GetVar, /* 175 */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 7b0df05..a8ca463 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -727,7 +727,7 @@ Tcltest_SafeInit( static int TestasyncCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -937,7 +937,7 @@ AsyncThreadProc( static int TestbumpinterpepochObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -972,7 +972,7 @@ TestbumpinterpepochObjCmd( static int TestcmdinfoCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1099,7 +1099,7 @@ CmdDelProc2( static int TestcmdtokenCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1162,7 +1162,7 @@ TestcmdtokenCmd( static int TestcmdtraceCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1259,7 +1259,7 @@ CmdTraceProc( char *command, /* The command being traced (after * substitutions). */ TCL_UNUSED(Tcl_CmdProc *) /*cmdProc*/, - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), int argc, /* Number of arguments. */ const char *argv[]) /* Argument strings. */ { @@ -1277,12 +1277,12 @@ CmdTraceProc( static void CmdTraceDeleteProc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ TCL_UNUSED(int) /*level*/, TCL_UNUSED(char *) /*command*/, TCL_UNUSED(Tcl_CmdProc *), - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), TCL_UNUSED(int) /*argc*/, TCL_UNUSED(const char **) /*argv*/) { @@ -1297,7 +1297,7 @@ CmdTraceDeleteProc( static int ObjTraceProc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ TCL_UNUSED(int) /*level*/, const char *command, @@ -1354,7 +1354,7 @@ ObjTraceDeleteProc( static int TestcreatecommandCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1384,7 +1384,7 @@ TestcreatecommandCmd( static int CreatedCommandProc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ TCL_UNUSED(int) /*argc*/, TCL_UNUSED(const char **) /*argv*/) @@ -1406,7 +1406,7 @@ CreatedCommandProc( static int CreatedCommandProc2( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ TCL_UNUSED(int) /*argc*/, TCL_UNUSED(const char **) /*argv*/) @@ -1444,7 +1444,7 @@ CreatedCommandProc2( static int TestdcallCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1508,21 +1508,21 @@ DelCallbackProc( static int TestdelCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { DelCmd *dPtr; - Tcl_Interp *slave; + Tcl_Interp *child; if (argc != 4) { Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } - slave = Tcl_GetSlave(interp, argv[1]); - if (slave == NULL) { + child = Tcl_GetChild(interp, argv[1]); + if (child == NULL) { return TCL_ERROR; } @@ -1531,7 +1531,7 @@ TestdelCmd( dPtr->deleteCmd = (char *)ckalloc(strlen(argv[3]) + 1); strcpy(dPtr->deleteCmd, argv[3]); - Tcl_CreateCommand(slave, argv[2], DelCmdProc, dPtr, + Tcl_CreateCommand(child, argv[2], DelCmdProc, dPtr, DelDeleteProc); return TCL_OK; } @@ -1583,7 +1583,7 @@ DelDeleteProc( static int TestdelassocdataCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1620,7 +1620,7 @@ TestdelassocdataCmd( static int TestdoubledigitsObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj* const objv[]) /* Parameter vector */ @@ -1707,7 +1707,7 @@ TestdoubledigitsObjCmd( static int TestdstringCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1833,7 +1833,7 @@ static void SpecialFree( static int TestencodingObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1993,7 +1993,7 @@ EncodingFreeProc( static int TestevalexObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2038,7 +2038,7 @@ TestevalexObjCmd( static int TestevalobjvObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2087,7 +2087,7 @@ TestevalobjvObjCmd( static int TesteventObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const objv[]) /* Parameter vector */ @@ -2266,7 +2266,7 @@ TesteventDeleteProc( static int TestexithandlerCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2342,7 +2342,7 @@ ExitProcEven( static int TestexprlongCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2385,7 +2385,7 @@ TestexprlongCmd( static int TestexprlongobjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument objects. */ @@ -2427,7 +2427,7 @@ TestexprlongobjCmd( static int TestexprdoubleCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2471,7 +2471,7 @@ TestexprdoubleCmd( static int TestexprdoubleobjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument objects. */ @@ -2513,7 +2513,7 @@ TestexprdoubleobjCmd( static int TestexprstringCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2545,7 +2545,7 @@ TestexprstringCmd( static int TestfilelinkCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -2612,7 +2612,7 @@ TestfilelinkCmd( static int TestgetassocdataCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2650,7 +2650,7 @@ TestgetassocdataCmd( static int TestgetplatformCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2690,23 +2690,23 @@ TestgetplatformCmd( static int TestinterpdeleteCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { - Tcl_Interp *slaveToDelete; + Tcl_Interp *childToDelete; if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " path\"", NULL); return TCL_ERROR; } - slaveToDelete = Tcl_GetSlave(interp, argv[1]); - if (slaveToDelete == NULL) { + childToDelete = Tcl_GetChild(interp, argv[1]); + if (childToDelete == NULL) { return TCL_ERROR; } - Tcl_DeleteInterp(slaveToDelete); + Tcl_DeleteInterp(childToDelete); return TCL_OK; } @@ -2730,7 +2730,7 @@ TestinterpdeleteCmd( static int TestlinkCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -3198,7 +3198,7 @@ TestlinkCmd( static int TestlinkarrayCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3206,7 +3206,7 @@ TestlinkarrayCmd( static const char *LinkOption[] = { "update", "remove", "create", NULL }; - enum LinkOption { LINK_UPDATE, LINK_REMOVE, LINK_CREATE }; + enum LinkOptionEnum { LINK_UPDATE, LINK_REMOVE, LINK_CREATE }; static const char *LinkType[] = { "char", "uchar", "short", "ushort", "int", "uint", "long", "ulong", "wide", "uwide", "float", "double", "string", "char*", "binary", NULL @@ -3231,7 +3231,7 @@ TestlinkarrayCmd( &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum LinkOption) optionIndex) { + switch ((enum LinkOptionEnum) optionIndex) { case LINK_UPDATE: for (i=2; i<objc; i++) { Tcl_UpdateLinkedVar(interp, Tcl_GetString(objv[i])); @@ -3316,7 +3316,7 @@ TestlinkarrayCmd( static int TestlocaleCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3402,7 +3402,7 @@ CleanupTestSetassocdataTests( static int TestparserObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3458,7 +3458,7 @@ TestparserObjCmd( static int TestexprparserObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3605,7 +3605,7 @@ PrintParse( static int TestparsevarObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3646,7 +3646,7 @@ TestparsevarObjCmd( static int TestparsevarnameObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3709,7 +3709,7 @@ TestparsevarnameObjCmd( static int TestpreferstableObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ TCL_UNUSED(int) /*objc*/, TCL_UNUSED(Tcl_Obj *const *) /*objv*/) @@ -3739,7 +3739,7 @@ TestpreferstableObjCmd( static int TestprintObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3780,7 +3780,7 @@ TestprintObjCmd( static int TestregexpObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3797,7 +3797,7 @@ TestregexpObjCmd( "-xflags", "--", NULL }; - enum options { + enum optionsEnum { REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED, REGEXP_MULTI, REGEXP_NOCROSS, REGEXP_NEWL, REGEXP_XFLAGS, @@ -3822,7 +3822,7 @@ TestregexpObjCmd( &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum options) index) { + switch ((enum optionsEnum) index) { case REGEXP_INDICES: indices = 1; break; @@ -4103,7 +4103,7 @@ TestregexpXflags( static int TestreturnObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), TCL_UNUSED(Tcl_Interp *), TCL_UNUSED(int) /*objc*/, TCL_UNUSED(Tcl_Obj *const *) /*objv*/) @@ -4131,7 +4131,7 @@ TestreturnObjCmd( static int TestsetassocdataCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4182,7 +4182,7 @@ TestsetassocdataCmd( static int TestsetplatformCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4231,7 +4231,7 @@ TestsetplatformCmd( static int TeststaticpkgCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4282,7 +4282,7 @@ StaticInitProc( static int TesttranslatefilenameCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4323,7 +4323,7 @@ TesttranslatefilenameCmd( static int TestupvarCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4375,7 +4375,7 @@ TestupvarCmd( static int TestseterrorcodeCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4427,7 +4427,7 @@ TestseterrorcodeCmd( static int TestsetobjerrorcodeCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -4455,7 +4455,7 @@ TestsetobjerrorcodeCmd( static int TestfeventCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4527,7 +4527,7 @@ TestfeventCmd( static int TestpanicCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), TCL_UNUSED(Tcl_Interp *), int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4546,7 +4546,7 @@ TestpanicCmd( static int TestfileCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ Tcl_Obj *const argv[]) /* The argument objects. */ @@ -4628,7 +4628,7 @@ TestfileCmd( static int TestgetvarfullnameCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -4702,7 +4702,7 @@ TestgetvarfullnameCmd( static int GetTimesObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* The current interpreter. */ TCL_UNUSED(int) /*cobjc*/, TCL_UNUSED(Tcl_Obj *const *) /*cobjv*/) @@ -4881,7 +4881,7 @@ GetTimesObjCmd( static int NoopCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), TCL_UNUSED(Tcl_Interp *), TCL_UNUSED(int) /*argc*/, TCL_UNUSED(const char **) /*argv*/) @@ -4908,7 +4908,7 @@ NoopCmd( static int NoopObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), TCL_UNUSED(Tcl_Interp *), TCL_UNUSED(int) /*objc*/, TCL_UNUSED(Tcl_Obj *const *) /*objv*/) @@ -4933,7 +4933,7 @@ NoopObjCmd( static int TeststringbytesObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -4973,7 +4973,7 @@ TeststringbytesObjCmd( static int TestpurebytesobjObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -5020,7 +5020,7 @@ TestpurebytesobjObjCmd( static int TestsetbytearraylengthObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -5064,7 +5064,7 @@ TestsetbytearraylengthObjCmd( static int TestbytestringObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -5186,7 +5186,7 @@ Testset2Cmd( static int TestsaveresultCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp,/* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -5317,7 +5317,7 @@ TestsaveresultFree( static int TestmainthreadCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ TCL_UNUSED(const char **) /*argv*/) @@ -5378,7 +5378,7 @@ MainLoop(void) static int TestsetmainloopCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), TCL_UNUSED(Tcl_Interp *), TCL_UNUSED(int) /*argc*/, TCL_UNUSED(const char **) /*argv*/) @@ -5407,7 +5407,7 @@ TestsetmainloopCmd( static int TestexitmainloopCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), TCL_UNUSED(Tcl_Interp *), TCL_UNUSED(int) /*argc*/, TCL_UNUSED(const char **) /*argv*/) @@ -5435,7 +5435,7 @@ TestexitmainloopCmd( static int TestChannelCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Interpreter for result. */ int argc, /* Count of additional args. */ const char **argv) /* Additional arg strings. */ @@ -5902,7 +5902,7 @@ TestChannelCmd( static int TestChannelEventCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -6114,7 +6114,7 @@ TestChannelEventCmd( static int TestSocketCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Interpreter for result. */ int argc, /* Count of additional args. */ const char **argv) /* Additional arg strings. */ @@ -6185,7 +6185,7 @@ TestSocketCmd( static int TestServiceModeCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -6229,7 +6229,7 @@ TestServiceModeCmd( static int TestWrongNumArgsObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -6285,7 +6285,7 @@ TestWrongNumArgsObjCmd( static int TestGetIndexFromObjStructObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -6339,7 +6339,7 @@ TestGetIndexFromObjStructObjCmd( static int TestFilesystemObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -6681,7 +6681,7 @@ TestReportNormalizePath( static int SimplePathInFilesystem( Tcl_Obj *pathPtr, - TCL_UNUSED(ClientData *)) + TCL_UNUSED(void **)) { const char *str = Tcl_GetString(pathPtr); @@ -6710,7 +6710,7 @@ SimplePathInFilesystem( static int TestSimpleFilesystemObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -6971,7 +6971,7 @@ TestUtfPrevCmd( static int TestNumUtfCharsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -7000,7 +7000,7 @@ TestNumUtfCharsCmd( static int TestFindFirstCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -7022,7 +7022,7 @@ TestFindFirstCmd( static int TestFindLastCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -7064,7 +7064,7 @@ TestFindLastCmd( static int TestcpuidCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const * objv) /* Parameter vector */ @@ -7100,7 +7100,7 @@ TestcpuidCmd( static int TestHashSystemHashCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -7176,7 +7176,7 @@ TestHashSystemHashCmd( */ static int TestgetintCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int argc, const char **argv) @@ -7203,7 +7203,7 @@ TestgetintCmd( */ static int TestlongsizeCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int argc, TCL_UNUSED(const char **) /*argv*/) @@ -7245,7 +7245,7 @@ NREUnwind_callback( static int TestNREUnwind( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, TCL_UNUSED(int) /*objc*/, TCL_UNUSED(Tcl_Obj *const *) /*objv*/) @@ -7263,7 +7263,7 @@ TestNREUnwind( static int TestNRELevels( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, TCL_UNUSED(int) /*objc*/, TCL_UNUSED(Tcl_Obj *const *) /*objv*/) @@ -7319,7 +7319,7 @@ TestNRELevels( static int TestconcatobjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ TCL_UNUSED(int) /*argc*/, TCL_UNUSED(const char **) /*argv*/) @@ -7488,8 +7488,6 @@ TestconcatobjCmd( "\n\t* (e) concatObj does not have refCount 0", NULL); } if (concatPtr == tmpPtr) { - int len; - result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (e) concatObj is not a new obj ", NULL); @@ -7520,8 +7518,6 @@ TestconcatobjCmd( "\n\t* (f) concatObj does not have refCount 0", NULL); } if (concatPtr == tmpPtr) { - int len; - result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (f) concatObj is not a new obj ", NULL); @@ -7553,8 +7549,6 @@ TestconcatobjCmd( "\n\t* (g) concatObj does not have refCount 0", NULL); } if (concatPtr == tmpPtr) { - int len; - result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (g) concatObj is not a new obj ", NULL); @@ -7615,7 +7609,7 @@ TestconcatobjCmd( static int TestgetencpathObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ @@ -7648,7 +7642,7 @@ TestgetencpathObjCmd( static int TestsetencpathObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ @@ -7682,7 +7676,7 @@ TestsetencpathObjCmd( static int TestparseargsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Arguments. */ @@ -7921,7 +7915,7 @@ InterpCompiledVarResolver( static int TestInterpResolverCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -7937,7 +7931,7 @@ TestInterpResolverCmd( return TCL_ERROR; } if (objc == 3) { - interp = Tcl_GetSlave(interp, Tcl_GetString(objv[2])); + interp = Tcl_GetChild(interp, Tcl_GetString(objv[2])); if (interp == NULL) { Tcl_AppendResult(interp, "provided interpreter not found", NULL); return TCL_ERROR; diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index bfd0a45..bd5d92e 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -149,7 +149,7 @@ TclObjTest_Init( static int TestbignumobjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Argument count */ Tcl_Obj *const objv[]) /* Argument vector */ @@ -348,7 +348,7 @@ TestbignumobjCmd( static int TestbooleanobjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -448,7 +448,7 @@ TestbooleanobjCmd( static int TestdoubleobjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -566,7 +566,7 @@ TestdoubleobjCmd( static int TestindexobjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -627,7 +627,7 @@ TestindexobjCmd( argv[objc-4] = NULL; result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3], - argv, "token", INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT), + argv, "token", TCL_INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT), &index); ckfree(argv); if (result == TCL_OK) { @@ -656,7 +656,7 @@ TestindexobjCmd( static int TestintobjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -860,7 +860,7 @@ TestintobjCmd( static int TestlistobjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Number of arguments */ Tcl_Obj *const objv[]) /* Argument objects */ @@ -957,7 +957,7 @@ TestlistobjCmd( static int TestobjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1169,7 +1169,7 @@ TestobjCmd( static int TeststringobjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index 09dfbef..db6ec8a 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -228,7 +228,7 @@ ProcBodyTestInitInternal( static int ProcBodyTestProcObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* the current interpreter */ int objc, /* argument count */ Tcl_Obj *const objv[]) /* arguments */ @@ -327,7 +327,7 @@ ProcBodyTestProcObjCmd( static int ProcBodyTestCheckObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* the current interpreter */ int objc, /* argument count */ Tcl_Obj *const objv[]) /* arguments */ diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index ace69a0..0bb55e1 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -205,7 +205,7 @@ TclThread_Init( static int ThreadObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -413,7 +413,7 @@ ThreadObjCmd( Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj( + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT))); return TCL_OK; } @@ -1105,7 +1105,7 @@ ThreadFreeProc( static int ThreadDeleteEvent( Tcl_Event *eventPtr, /* Really ThreadEvent */ - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { if (eventPtr->proc == ThreadEventProc) { ckfree(((ThreadEvent *) eventPtr)->script); diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 05a80b0..6b94cbb 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -792,7 +792,7 @@ Tcl_AfterObjCmd( static const char *const afterSubCmds[] = { "cancel", "idle", "info", NULL }; - enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO}; + enum afterSubCmdsEnum {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO}; ThreadSpecificData *tsdPtr = InitTimer(); if (objc < 2) { @@ -942,8 +942,9 @@ Tcl_AfterObjCmd( break; case AFTER_INFO: if (objc == 2) { - Tcl_Obj *resultObj = Tcl_NewObj(); + Tcl_Obj *resultObj; + TclNewObj(resultObj); for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { if (assocPtr->interp == interp) { @@ -967,8 +968,9 @@ Tcl_AfterObjCmd( Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL); return TCL_ERROR; } else { - Tcl_Obj *resultListPtr = Tcl_NewObj(); + Tcl_Obj *resultListPtr; + TclNewObj(resultListPtr); Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr); Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 9896e0e..d189581 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -183,7 +183,7 @@ typedef struct { int Tcl_TraceObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -202,7 +202,7 @@ Tcl_TraceObjCmd( NULL }; /* 'OLD' options are pre-Tcl-8.4 style */ - enum traceOptions { + enum traceOptionsEnum { TRACE_ADD, TRACE_INFO, TRACE_REMOVE, #ifndef TCL_REMOVE_OBSOLETE_TRACES TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO @@ -218,7 +218,7 @@ Tcl_TraceObjCmd( &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum traceOptions) optionIndex) { + switch ((enum traceOptionsEnum) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { /* @@ -276,7 +276,7 @@ Tcl_TraceObjCmd( return TCL_ERROR; } - opsList = Tcl_NewObj(); + TclNewObj(opsList); Tcl_IncrRefCount(opsList); flagOps = TclGetStringFromObj(objv[3], &numFlags); if (numFlags == 0) { @@ -320,7 +320,7 @@ Tcl_TraceObjCmd( Tcl_WrongNumArgs(interp, 2, objv, "name"); return TCL_ERROR; } - resultListPtr = Tcl_NewObj(); + TclNewObj(resultListPtr); name = Tcl_GetString(objv[2]); FOREACH_VAR_TRACE(interp, name, clientData) { TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData; @@ -965,7 +965,7 @@ TraceVariableObjCmd( return TCL_ERROR; } - resultListPtr = Tcl_NewObj(); + TclNewObj(resultListPtr); name = Tcl_GetString(objv[3]); FOREACH_VAR_TRACE(interp, name, clientData) { Tcl_Obj *opObjPtr, *eachTraceObjPtr, *elemObjPtr; @@ -1177,7 +1177,7 @@ Tcl_UntraceCommand( CommandTrace *tracePtr; CommandTrace *prevPtr; Command *cmdPtr; - Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *)interp; ActiveCommandTrace *activePtr; int hasExecTraces = 0; @@ -1252,7 +1252,6 @@ Tcl_UntraceCommand( */ if (cmdPtr->compileProc != NULL) { - Interp *iPtr = (Interp *) interp; iPtr->compileEpoch++; } } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 5b296f0..170a85e 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2040,7 +2040,7 @@ Tcl_ConcatObj( } } if (!resPtr) { - resPtr = Tcl_NewObj(); + TclNewObj(resPtr); } return resPtr; } @@ -3757,7 +3757,7 @@ GetEndOffsetFromObj( if (*bytes != 'e') { int numType; const char *opPtr; - int length, t1 = 0, t2 = 0; + int t1 = 0, t2 = 0; /* Value doesn't start with "e" */ @@ -3774,7 +3774,7 @@ GetEndOffsetFromObj( * Quick scan to see if multi-value list is even possible. * This relies on TclGetString() returning a NUL-terminated string. */ - if ((TclMaxListLength(TclGetString(objPtr), -1, NULL) > 1) + if ((TclMaxListLength(bytes, -1, NULL) > 1) /* If it's possible, do the full list parse. */ && (TCL_OK == Tcl_ListObjLength(NULL, objPtr, &length)) @@ -3817,7 +3817,7 @@ GetEndOffsetFromObj( if ((t1 == TCL_NUMBER_INT) && (t2 == TCL_NUMBER_INT)) { /* Both are wide, do wide-integer math */ if (*opPtr == '-') { - if ((w2 == WIDE_MIN) && (interp != NULL)) { + if (w2 == WIDE_MIN) { goto extreme; } w2 = -w2; @@ -3839,13 +3839,6 @@ GetEndOffsetFromObj( offset = WIDE_MIN; } } - } else if (interp == NULL) { - /* - * We use an interp to do bignum index calculations. - * If we don't get one, call all indices with bignums errors, - * and rely on callers to handle it. - */ - goto parseError; } else { /* * At least one is big, do bignum math. Little reason to @@ -3856,7 +3849,13 @@ GetEndOffsetFromObj( Tcl_Obj *sum; extreme: - Tcl_ExprObj(interp, objPtr, &sum); + if (interp) { + Tcl_ExprObj(interp, objPtr, &sum); + } else { + Tcl_Interp *compute = Tcl_CreateInterp(); + Tcl_ExprObj(compute, objPtr, &sum); + Tcl_DeleteInterp(compute); + } TclGetNumberFromObj(NULL, sum, &cd, &numType); if (numType == TCL_NUMBER_INT) { diff --git a/generic/tclVar.c b/generic/tclVar.c index 2818fc9..0f0bc25 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -119,17 +119,17 @@ VarHashNextVar( * access is denied. */ -static const char *noSuchVar = "no such variable"; -static const char *isArray = "variable is array"; -static const char *needArray = "variable isn't array"; -static const char *noSuchElement = "no such element in array"; -static const char *danglingElement = +static const char NOSUCHVAR[] = "no such variable"; +static const char ISARRAY[] = "variable is array"; +static const char NEEDARRAY[] = "variable isn't array"; +static const char NOSUCHELEMENT[] = "no such element in array"; +static const char DANGLINGELEMENT[] = "upvar refers to element in deleted array"; -static const char *danglingVar = +static const char DANGLINGVAR[] = "upvar refers to variable in deleted namespace"; -static const char *badNamespace = "parent namespace doesn't exist"; -static const char *missingName = "missing variable name"; -static const char *isArrayElement = +static const char BADNAMESPACE[] = "parent namespace doesn't exist"; +static const char MISSINGNAME[] = "missing variable name"; +static const char ISARRAYELEMENT[] = "name refers to an element in an array"; /* @@ -649,7 +649,7 @@ TclObjLookupVarEx( if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, - noSuchVar, -1); + NOSUCHVAR, -1); Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", NULL); } return NULL; @@ -674,7 +674,7 @@ TclObjLookupVarEx( if (part2Ptr != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, - needArray, -1); + NEEDARRAY, -1); Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", NULL); } @@ -939,7 +939,7 @@ TclLookupSimpleVar( Tcl_Obj *tailPtr; if (!create) { /* Var wasn't found and not to create it. */ - *errMsgPtr = noSuchVar; + *errMsgPtr = NOSUCHVAR; return NULL; } @@ -950,10 +950,10 @@ TclLookupSimpleVar( TclGetNamespaceForQualName(interp, varName, cxtNsPtr, flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); if (varNsPtr == NULL) { - *errMsgPtr = badNamespace; + *errMsgPtr = BADNAMESPACE; return NULL; } else if (tail == NULL) { - *errMsgPtr = missingName; + *errMsgPtr = MISSINGNAME; return NULL; } if (tail != varName) { @@ -1010,7 +1010,7 @@ TclLookupSimpleVar( varPtr = VarHashFindVar(tablePtr, varNamePtr); } if (varPtr == NULL) { - *errMsgPtr = noSuchVar; + *errMsgPtr = NOSUCHVAR; } } } @@ -1088,7 +1088,7 @@ TclLookupArrayElement( if (!createArray) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, - noSuchVar, index); + NOSUCHVAR, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); } @@ -1103,7 +1103,7 @@ TclLookupArrayElement( if (TclIsVarDeadHash(arrayPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, - danglingVar, index); + DANGLINGVAR, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); } @@ -1113,7 +1113,7 @@ TclLookupArrayElement( TclInitArrayVar(arrayPtr); } else if (!TclIsVarArray(arrayPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { - TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, needArray, + TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, NEEDARRAY, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); @@ -1135,7 +1135,7 @@ TclLookupArrayElement( if (varPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, - noSuchElement, index); + NOSUCHELEMENT, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", TclGetString(elNamePtr), NULL); } @@ -1485,11 +1485,11 @@ TclPtrGetVarIdx( if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarUndefined(varPtr) && arrayPtr && !TclIsVarUndefined(arrayPtr)) { - msg = noSuchElement; + msg = NOSUCHELEMENT; } else if (TclIsVarArray(varPtr)) { - msg = isArray; + msg = ISARRAY; } else { - msg = noSuchVar; + msg = NOSUCHVAR; } TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "read", msg, index); } @@ -2024,11 +2024,11 @@ TclPtrSetVarIdx( if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarArrayElement(varPtr)) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", - danglingElement, index); + DANGLINGELEMENT, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", NULL); } else { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", - danglingVar, index); + DANGLINGVAR, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", NULL); } } @@ -2041,7 +2041,7 @@ TclPtrSetVarIdx( if (TclIsVarArray(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { - TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", isArray,index); + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", ISARRAY,index); Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); } goto earlyError; @@ -2609,7 +2609,7 @@ TclPtrUnsetVarIdx( if (result != TCL_OK) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", - ((arrayPtr == NULL) ? noSuchVar : noSuchElement), index); + ((arrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index); Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", NULL); } } @@ -3917,7 +3917,7 @@ ArrayNamesCmd( static const char *const options[] = { "-exact", "-glob", "-regexp", NULL }; - enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; + enum arrayNamesOptionsEnum { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; Var *varPtr, *varPtr2; Tcl_Obj *nameObj, *resultObj, *patternObj; Tcl_HashSearch search; @@ -3985,7 +3985,7 @@ ArrayNamesCmd( const char *name = TclGetString(nameObj); int matched = 0; - switch ((enum options) mode) { + switch ((enum arrayNamesOptionsEnum) mode) { case OPT_EXACT: Tcl_Panic("exact matching shouldn't get here"); case OPT_GLOB: @@ -4104,7 +4104,7 @@ ArraySetCmd( } if (arrayPtr) { CleanupVar(varPtr, arrayPtr); - TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1); + TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", NEEDARRAY, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", TclGetString(arrayNameObj), NULL); return TCL_ERROR; @@ -4223,7 +4223,7 @@ ArraySetCmd( */ TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set", - needArray, -1); + NEEDARRAY, -1); Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); return TCL_ERROR; } @@ -4286,7 +4286,7 @@ ArraySizeCmd( } } - Tcl_SetObjResult(interp, Tcl_NewIntObj(size)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(size)); return TCL_OK; } @@ -5124,7 +5124,7 @@ Tcl_VariableObjCmd( */ TclObjVarErrMsg(interp, varNamePtr, NULL, "define", - isArrayElement, -1); + ISARRAYELEMENT, -1); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL); return TCL_ERROR; } @@ -5451,7 +5451,8 @@ TclDeleteNamespaceVars( for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL; varPtr = VarHashFirstVar(tablePtr, &search)) { - Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_Obj *objPtr; + TclNewObj(objPtr); VarHashRefCount(varPtr)++; /* Make sure we get to remove from * hash. */ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); @@ -6120,7 +6121,7 @@ TclInfoVarsCmd( if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { if (specificNsInPattern) { - elemObjPtr = Tcl_NewObj(); + TclNewObj(elemObjPtr); Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, elemObjPtr); } else { @@ -6153,7 +6154,7 @@ TclInfoVarsCmd( if ((simplePattern == NULL) || Tcl_StringMatch(varName, simplePattern)) { if (specificNsInPattern) { - elemObjPtr = Tcl_NewObj(); + TclNewObj(elemObjPtr); Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, elemObjPtr); } else { @@ -6634,7 +6635,7 @@ ArrayDefaultCmd( static const char *const options[] = { "get", "set", "exists", "unset", NULL }; - enum options { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET }; + enum arrayDefaultOptionsEnum { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET }; Tcl_Obj *arrayNameObj, *defaultValueObj; Var *varPtr, *arrayPtr; int isArray, option; @@ -6658,7 +6659,7 @@ ArrayDefaultCmd( return TCL_ERROR; } - switch (option) { + switch ((enum arrayDefaultOptionsEnum)option) { case OPT_GET: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); @@ -6701,7 +6702,7 @@ ArrayDefaultCmd( CleanupVar(varPtr, arrayPtr); TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", - needArray, -1); + NEEDARRAY, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", TclGetString(arrayNameObj), NULL); return TCL_ERROR; @@ -6712,7 +6713,7 @@ ArrayDefaultCmd( */ TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", - needArray, -1); + NEEDARRAY, -1); Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); return TCL_ERROR; } diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 695c814..4a13970 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -3238,7 +3238,7 @@ ZipFSTclLibraryObjCmd( Tcl_Obj *pResult = TclZipfs_TclLibrary(); if (!pResult) { - pResult = Tcl_NewObj(); + TclNewObj(pResult); } Tcl_SetObjResult(interp, pResult); } @@ -4485,13 +4485,13 @@ ZipFSFileAttrsGetProc( } switch (index) { case 0: - *objPtrRef = Tcl_NewWideIntObj(z->numBytes); + TclNewIntObj(*objPtrRef, z->numBytes); break; case 1: - *objPtrRef = Tcl_NewWideIntObj(z->numCompressedBytes); + TclNewIntObj(*objPtrRef, z->numCompressedBytes); break; case 2: - *objPtrRef = Tcl_NewWideIntObj(z->offset); + TclNewIntObj(*objPtrRef, z->offset); break; case 3: *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint, diff --git a/generic/tclZlib.c b/generic/tclZlib.c index e70c4b3..ea6a1f2 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -354,7 +354,7 @@ ConvertErrorToList( return Tcl_NewListObj(4, objv); case Z_NEED_DICT: TclNewLiteralStringObj(objv[2], "NEED_DICT"); - objv[3] = Tcl_NewWideIntObj((Tcl_WideInt) adler); + TclNewIntObj(objv[3], (Tcl_WideInt)adler); return Tcl_NewListObj(4, objv); /* @@ -2162,7 +2162,7 @@ ZlibCmd( break; case 1: headerVarObj = objv[i+1]; - headerDictObj = Tcl_NewObj(); + TclNewObj(headerDictObj); break; } } @@ -2398,7 +2398,7 @@ ZlibPushSubcmd( "-dictionary", "-header", "-level", "-limit", NULL }; const char *const *pushOptions = pushDecompressOptions; - enum pushOptions {poDictionary, poHeader, poLevel, poLimit}; + enum pushOptionsEnum {poDictionary, poHeader, poLevel, poLimit}; Tcl_Obj *headerObj = NULL, *compDictObj = NULL; int limit = DEFAULT_BUFFER_SIZE, dummy; @@ -2480,7 +2480,7 @@ ZlibPushSubcmd( Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); return TCL_ERROR; } - switch ((enum pushOptions) option) { + switch ((enum pushOptionsEnum) option) { case poHeader: headerObj = objv[i]; if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) { @@ -2703,21 +2703,21 @@ ZlibStreamAddCmd( switch ((enum addOptions) index) { case ao_flush: /* -flush */ - if (flush > -1) { + if (flush >= 0) { flush = -2; } else { flush = Z_SYNC_FLUSH; } break; case ao_fullflush: /* -fullflush */ - if (flush > -1) { + if (flush >= 0) { flush = -2; } else { flush = Z_FULL_FLUSH; } break; case ao_finalize: /* -finalize */ - if (flush > -1) { + if (flush >= 0) { flush = -2; } else { flush = Z_FINISH; @@ -2830,21 +2830,21 @@ ZlibStreamPutCmd( switch ((enum putOptions) index) { case po_flush: /* -flush */ - if (flush > -1) { + if (flush >= 0) { flush = -2; } else { flush = Z_SYNC_FLUSH; } break; case po_fullflush: /* -fullflush */ - if (flush > -1) { + if (flush >= 0) { flush = -2; } else { flush = Z_FULL_FLUSH; } break; case po_finalize: /* -finalize */ - if (flush > -1) { + if (flush >= 0) { flush = -2; } else { flush = Z_FINISH; @@ -3484,8 +3484,9 @@ ZlibTransformGetOption( if ((cd->flags & IN_HEADER) && ((optionName == NULL) || (strcmp(optionName, "-header") == 0))) { - Tcl_Obj *tmpObj = Tcl_NewObj(); + Tcl_Obj *tmpObj; + TclNewObj(tmpObj); ExtractHeader(&cd->inHeader.header, tmpObj); if (optionName == NULL) { Tcl_DStringAppendElement(dsPtr, "-header"); @@ -3944,7 +3945,7 @@ TclZlibInit( cfg[0].key = "zlibVersion"; cfg[0].value = zlibVersion(); cfg[1].key = NULL; - Tcl_RegisterConfig(interp, "zlib", cfg, "iso8859-1"); + Tcl_RegisterConfig(interp, "zlib", cfg, "utf-8"); /* * Allow command type introspection to do something sensible with streams. diff --git a/library/auto.tcl b/library/auto.tcl index 2deae05..32da97c 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -265,6 +265,7 @@ proc auto_mkindex {dir args} { auto_mkindex_parser::cleanup set fid [open "tclIndex" w] + fconfigure $fid -translation lf puts -nonewline $fid $index close $fid cd $oldDir @@ -291,6 +292,7 @@ proc auto_mkindex_old {dir args} { set f "" set error [catch { set f [open $file] + fconfigure $f -eofchar \032 while {[gets $f line] >= 0} { if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} { set procName [lindex [auto_qualify $procName "::"] 0] @@ -309,6 +311,7 @@ proc auto_mkindex_old {dir args} { set f "" set error [catch { set f [open tclIndex w] + fconfigure $f -translation lf puts -nonewline $f $index close $f cd $oldDir @@ -401,6 +404,7 @@ proc auto_mkindex_parser::mkindex {file} { set scriptFile $file set fid [open $file] + fconfigure $fid -eofchar \032 set contents [read $fid] close $fid diff --git a/library/clock.tcl b/library/clock.tcl index 49dfdbe..54919f2 100644 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -3304,7 +3304,7 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { return } - # Since an unsafe interp uses the [clock] command in the master, this code + # Since an unsafe interp uses the [clock] command in the parent, this code # is security sensitive. Make sure that the path name cannot escape the # given directory. @@ -3314,7 +3314,7 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { "time zone \":$fileName\" not valid" } try { - source -encoding utf-8 [file join $DataDir $fileName] + source [file join $DataDir $fileName] } on error {} { return -code error \ -errorcode [list CLOCK badTimeZone :$fileName] \ @@ -3344,7 +3344,7 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { proc ::tcl::clock::LoadZoneinfoFile { fileName } { variable ZoneinfoPaths - # Since an unsafe interp uses the [clock] command in the master, this code + # Since an unsafe interp uses the [clock] command in the parent, this code # is security sensitive. Make sure that the path name cannot escape the # given directory. diff --git a/library/http/http.tcl b/library/http/http.tcl index 2cef614..df8fe2d 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -11,7 +11,7 @@ package require Tcl 8.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.9.3 +package provide http 2.10.0a1 namespace eval http { # Allow resourcing to not clobber existing data @@ -544,7 +544,7 @@ proc http::CloseSocket {s {token {}}} { } else { set map [array get socketMapping] set ndx [lsearch -exact $map $s] - if {$ndx != -1} { + if {$ndx >= 0} { incr ndx -1 set connId [lindex $map $ndx] } @@ -746,6 +746,7 @@ proc http::geturl {url args} { -strict boolean -timeout integer -validate boolean + -headers dict } set state(charset) $defaultCharset set options { @@ -759,9 +760,8 @@ proc http::geturl {url args} { foreach {flag value} $args { if {[regexp -- $pat $flag]} { # Validate numbers - if { - [info exists type($flag)] && - ![string is $type($flag) -strict $value] + if {($flag eq "-headers") ? [catch {dict size $value}] : + ([info exists type($flag)] && ![string is $type($flag) -strict $value]) } { unset $token return -code error \ @@ -983,6 +983,18 @@ proc http::geturl {url args} { set state(-pipeline) $http(-pipeline) } + # We cannot handle chunked encodings with -handler, so force HTTP/1.0 + # until we can manage this. + if {[info exists state(-handler)]} { + set state(-protocol) 1.0 + } + + # RFC 7320 A.1 - HTTP/1.0 Keep-Alive is problematic. We do not support it. + if {$state(-protocol) eq "1.0"} { + set state(connection) close + set state(-keepalive) 0 + } + # See if we are supposed to use a previously opened channel. # - In principle, ANY call to http::geturl could use a previously opened # channel if it is available - the "Connection: keep-alive" header is a @@ -1355,11 +1367,6 @@ proc http::Connected {token proto phost srvurl} { if {[info exists state(-method)] && ($state(-method) ne "")} { set how $state(-method) } - # We cannot handle chunked encodings with -handler, so force HTTP/1.0 - # until we can manage this. - if {[info exists state(-handler)]} { - set state(-protocol) 1.0 - } set accept_types_seen 0 Log ^B$tk begin sending request - token $token @@ -1382,7 +1389,7 @@ proc http::Connected {token proto phost srvurl} { puts $sock "Host: $host:$port" } puts $sock "User-Agent: $http(-useragent)" - if {($state(-protocol) >= 1.0) && $state(-keepalive)} { + if {($state(-protocol) > 1.0) && $state(-keepalive)} { # Send this header, because a 1.1 server is not compelled to treat # this as the default. puts $sock "Connection: keep-alive" @@ -1390,9 +1397,17 @@ proc http::Connected {token proto phost srvurl} { if {($state(-protocol) > 1.0) && !$state(-keepalive)} { puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1 } - if {[info exists phost] && ($phost ne "") && $state(-keepalive)} { - puts $sock "Proxy-Connection: Keep-Alive" - } + if {($state(-protocol) < 1.1)} { + # RFC7230 A.1 + # Some server implementations of HTTP/1.0 have a faulty + # implementation of RFC 2068 Keep-Alive. + # Don't leave this to chance. + # For HTTP/1.0 we have already "set state(connection) close" + # and "state(-keepalive) 0". + puts $sock "Connection: close" + } + # RFC7230 A.1 - "clients are encouraged not to send the + # Proxy-Connection header field in any requests" set accept_encoding_seen 0 set content_type_seen 0 dict for {key value} $state(-headers) { @@ -1668,9 +1683,51 @@ proc http::ReceiveResponse {token} { Log ^D$tk begin receiving response - token $token coroutine ${token}EventCoroutine http::Event $sock $token - fileevent $sock readable ${token}EventCoroutine + if {[info exists state(-handler)] || [info exists state(-progress)]} { + fileevent $sock readable [list http::EventGateway $sock $token] + } else { + fileevent $sock readable ${token}EventCoroutine + } + return } + +# http::EventGateway +# +# Bug [c2dc1da315]. +# - Recursive launch of the coroutine can occur if a -handler or -progress +# callback is used, and the callback command enters the event loop. +# - To prevent this, the fileevent "binding" is disabled while the +# coroutine is in flight. +# - If a recursive call occurs despite these precautions, it is not +# trapped and discarded here, because it is better to report it as a +# bug. +# - Although this solution is believed to be sufficiently general, it is +# used only if -handler or -progress is specified. In other cases, +# the coroutine is called directly. + +proc http::EventGateway {sock token} { + variable $token + upvar 0 $token state + fileevent $sock readable {} + catch {${token}EventCoroutine} res opts + if {[info commands ${token}EventCoroutine] ne {}} { + # The coroutine can be deleted by completion (a non-yield return), by + # http::Finish (when there is a premature end to the transaction), by + # http::reset or http::cleanup, or if the caller set option -channel + # but not option -handler: in the last case reading from the socket is + # now managed by commands ::http::Copy*, http::ReceiveChunked, and + # http::make-transformation-chunked. + # + # Catch in case the coroutine has closed the socket. + catch {fileevent $sock readable [list http::EventGateway $sock $token]} + } + + # If there was an error, re-throw it. + return -options $opts $res +} + + # http::NextPipelinedWrite # # - Connecting a socket to a token for writing is done by this command and by @@ -2734,20 +2791,21 @@ proc http::Event {sock token} { # scan any list for "close". if {$tmpHeader in {close keep-alive}} { # The common cases, continue. - } elseif {[string first , $tmpHeader] == -1} { + } elseif {[string first , $tmpHeader] < 0} { # Not a comma-separated list, not "close", # therefore "keep-alive". set tmpHeader keep-alive } else { - set tmpHeader keep-alive + set tmpResult keep-alive set tmpCsl [split $tmpHeader ,] # Optional whitespace either side of separator. foreach el $tmpCsl { if {[string trim $el] eq {close}} { - set tmpHeader close + set tmpResult close break } } + set tmpHeader $tmpResult } set state(connection) $tmpHeader } @@ -3186,7 +3244,7 @@ proc http::BlockingGets {sock} { while 1 { set count [gets $sock line] set eof [eof $sock] - if {$count > -1 || $eof} { + if {$count >= 0 || $eof} { return $line } else { yield diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 43cd86b..f312aac 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.6-]} {return} -package ifneeded http 2.9.3 [list tclPkgSetup $dir http 2.9.3 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.10.0a1 [list tclPkgSetup $dir http 2.10.0a1 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/library/init.tcl b/library/init.tcl index e62d05d..09dd6a4 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -112,7 +112,7 @@ if {[interp issafe]} { foreach cmd {add format scan} { proc ::tcl::clock::$cmd args { variable TclLibDir - source -encoding utf-8 [file join $TclLibDir clock.tcl] + source [file join $TclLibDir clock.tcl] return [uplevel 1 [info level 0]] } } @@ -245,7 +245,7 @@ proc unknown args { set errInfo [string range $errInfo 0 $last-1] set tail "\"$cinfo\"" set last [string last $tail $errInfo] - if {$last + [string length $tail] != [string length $errInfo]} { + if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} { return -code error -errorcode $errCode \ -errorinfo $errInfo $msg } @@ -442,6 +442,7 @@ proc auto_load_index {} { continue } else { set error [catch { + fconfigure $f -eofchar \032 set id [gets $f] if {$id eq "# Tcl autoload index file, version 2.0"} { eval [read $f] @@ -742,7 +743,7 @@ proc tcl::CopyDirectory {action src dest} { } } } else { - if {[string first $nsrc $ndest] != -1} { + if {[string first $nsrc $ndest] >= 0} { set srclen [expr {[llength [file split $nsrc]] - 1}] set ndest [lindex [file split $ndest] $srclen] if {$ndest eq [file tail $nsrc]} { diff --git a/library/install.tcl b/library/install.tcl index e62226e..26e5e68 100644 --- a/library/install.tcl +++ b/library/install.tcl @@ -35,6 +35,7 @@ proc ::practcl::_pkgindex_directory {path} { # Read the file, and override assumptions as needed ### set fin [open $file r] + fconfigure $fin -eofchar \032 set dat [read $fin] close $fin # Look for a teapot style Package statement @@ -58,6 +59,7 @@ proc ::practcl::_pkgindex_directory {path} { foreach file [glob -nocomplain $path/*.tcl] { if { [file tail $file] == "version_info.tcl" } continue set fin [open $file r] + fconfigure $fin -eofchar \032 set dat [read $fin] close $fin if {![regexp "package provide" $dat]} continue @@ -77,6 +79,7 @@ proc ::practcl::_pkgindex_directory {path} { return $buffer } set fin [open $pkgidxfile r] + fconfigure $fin -eofchar \032 set dat [read $fin] close $fin set trace 0 @@ -104,7 +107,7 @@ proc ::practcl::_pkgindex_directory {path} { } if {![regexp "package.*ifneeded" $thisline]} { # This package index contains arbitrary code - # source instead of trying to add it to the master + # source instead of trying to add it to the main # package index if {$trace} { puts "[file dirname $pkgidxfile] Arbitrary code $thisline" } return {source [file join $dir pkgIndex.tcl]} diff --git a/library/manifest.txt b/library/manifest.txt index 3a7ba54..51da565 100644 --- a/library/manifest.txt +++ b/library/manifest.txt @@ -5,9 +5,9 @@ apply {{dir} { set ::test [info script] set isafe [interp issafe] foreach {safe package version file} { - 0 http 2.9.3 {http http.tcl} + 0 http 2.10.0a1 {http http.tcl} 1 msgcat 1.7.1 {msgcat msgcat.tcl} - 1 opt 0.4.7 {opt optparse.tcl} + 1 opt 0.4.8 {opt optparse.tcl} 0 cookiejar 0.2.0 {cookiejar cookiejar.tcl} 0 tcl::idna 1.0.1 {cookiejar idna.tcl} 0 platform 1.0.14 {platform platform.tcl} diff --git a/library/opt/optparse.tcl b/library/opt/optparse.tcl index c8946fd..1639379 100644 --- a/library/opt/optparse.tcl +++ b/library/opt/optparse.tcl @@ -11,7 +11,7 @@ package require Tcl 8.5- # When this version number changes, update the pkgIndex.tcl file # and the install directory in the Makefiles. -package provide opt 0.4.7 +package provide opt 0.4.8 namespace eval ::tcl { @@ -44,8 +44,8 @@ namespace eval ::tcl { {-intflag 7} {-weirdflag "help string"} {-noStatics "Not ok to load static packages"} - {-nestedloading1 true "OK to load into nested slaves"} - {-nestedloading2 -boolean true "OK to load into nested slaves"} + {-nestedloading1 true "OK to load into nested children"} + {-nestedloading2 -boolean true "OK to load into nested children"} {-libsOK -choice {Tk SybTcl} "List of packages that can be loaded"} {-precision -int 12 "Number of digits of precision"} diff --git a/library/opt/pkgIndex.tcl b/library/opt/pkgIndex.tcl index daf9aa9..23e118c 100644 --- a/library/opt/pkgIndex.tcl +++ b/library/opt/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5-]} {return} -package ifneeded opt 0.4.7 [list source [file join $dir optparse.tcl]] +package ifneeded opt 0.4.8 [list source [file join $dir optparse.tcl]] diff --git a/library/package.tcl b/library/package.tcl index 6c87ec1..64fac7b 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -237,7 +237,7 @@ proc pkg_mkIndex {args} { $c eval [list set ::tcl::file $file] $c eval [list set ::tcl::direct $direct] - # Download needed procedures into the slave because we've just deleted + # Download needed procedures into the child because we've just deleted # the unknown procedure. This doesn't handle procedures with default # arguments. @@ -409,6 +409,7 @@ proc pkg_mkIndex {args} { } set f [open [file join $dir pkgIndex.tcl] w] + fconfigure $f -translation lf puts $f $index close $f } @@ -479,9 +480,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 +597,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 470cfa3..4c0f3b1 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -2,8 +2,8 @@ # # This file provide a safe loading/sourcing mechanism for safe interpreters. # It implements a virtual path mecanism to hide the real pathnames from the -# slave. It runs in a master interpreter and sets up data structure and -# aliases that will be invoked when used from a slave interpreter. +# child. It runs in a parent interpreter and sets up data structure and +# aliases that will be invoked when used from a child interpreter. # # See the safe.n man page for details. # @@ -20,7 +20,7 @@ # # Needed utilities package -package require opt 0.4.7 +package require opt 0.4.8 # Create the safe namespace namespace eval ::safe { @@ -79,25 +79,27 @@ proc ::safe::InterpNested {} { # Interface/entry point function and front end for "Create" proc ::safe::interpCreate {args} { set Args [::tcl::OptKeyParse ::safe::interpCreate $args] - InterpCreate $slave $accessPath \ + RejectExcessColons $child + InterpCreate $child $accessPath \ [InterpStatics] [InterpNested] $deleteHook } proc ::safe::interpInit {args} { set Args [::tcl::OptKeyParse ::safe::interpIC $args] - if {![::interp exists $slave]} { - return -code error "\"$slave\" is not an interpreter" + if {![::interp exists $child]} { + return -code error "\"$child\" is not an interpreter" } - InterpInit $slave $accessPath \ + RejectExcessColons $child + InterpInit $child $accessPath \ [InterpStatics] [InterpNested] $deleteHook } -# Check that the given slave is "one of us" -proc ::safe::CheckInterp {slave} { - namespace upvar ::safe S$slave state - if {![info exists state] || ![::interp exists $slave]} { +# Check that the given child is "one of us" +proc ::safe::CheckInterp {child} { + namespace upvar ::safe [VarName $child] state + if {![info exists state] || ![::interp exists $child]} { return -code error \ - "\"$slave\" is not an interpreter managed by ::safe::" + "\"$child\" is not an interpreter managed by ::safe::" } } @@ -119,11 +121,11 @@ proc ::safe::interpConfigure {args} { 1 { # If we have exactly 1 argument the semantic is to return all # the current configuration. We still call OptKeyParse though - # we know that "slave" is our given argument because it also + # we know that "child" is our given argument because it also # checks for the "-help" option. set Args [::tcl::OptKeyParse ::safe::interpIC $args] - CheckInterp $slave - namespace upvar ::safe S$slave state + CheckInterp $child + namespace upvar ::safe [VarName $child] state return [join [list \ [list -accessPath $state(access_path)] \ @@ -134,7 +136,7 @@ proc ::safe::interpConfigure {args} { 2 { # If we have exactly 2 arguments the semantic is a "configure # get" - lassign $args slave arg + lassign $args child arg # get the flag sub program (we 'know' about Opt's internal # representation of data) @@ -145,8 +147,8 @@ proc ::safe::interpConfigure {args} { } elseif {$hits == 0} { return -code error [::tcl::OptFlagUsage $desc $arg] } - CheckInterp $slave - namespace upvar ::safe S$slave state + CheckInterp $child + namespace upvar ::safe [VarName $child] state set item [::tcl::OptCurDesc $desc] set name [::tcl::OptName $item] @@ -186,16 +188,16 @@ proc ::safe::interpConfigure {args} { # Otherwise we want to parse the arguments like init and # create did set Args [::tcl::OptKeyParse ::safe::interpIC $args] - CheckInterp $slave - namespace upvar ::safe S$slave state + CheckInterp $child + namespace upvar ::safe [VarName $child] state # Get the current (and not the default) values of whatever has # not been given: if {![::tcl::OptProcArgGiven -accessPath]} { - set doreset 1 + set doreset 0 set accessPath $state(access_path) } else { - set doreset 0 + set doreset 1 } if { ![::tcl::OptProcArgGiven -statics] @@ -217,15 +219,34 @@ proc ::safe::interpConfigure {args} { set deleteHook $state(cleanupHook) } # we can now reconfigure : - InterpSetConfig $slave $accessPath $statics $nested $deleteHook - # auto_reset the slave (to completly synch the new access_path) + InterpSetConfig $child $accessPath $statics $nested $deleteHook + # auto_reset the child (to completly synch the new access_path) if {$doreset} { - if {[catch {::interp eval $slave {auto_reset}} msg]} { - Log $slave "auto_reset failed: $msg" + if {[catch {::interp eval $child {auto_reset}} msg]} { + Log $child "auto_reset failed: $msg" } else { - Log $slave "successful auto_reset" NOTICE + Log $child "successful auto_reset" NOTICE + } + + # Sync the paths used to search for Tcl modules. + ::interp eval $child {tcl::tm::path remove {*}[tcl::tm::list]} + if {[llength $state(tm_path_child)] > 0} { + ::interp eval $child [list \ + ::tcl::tm::add {*}[lreverse $state(tm_path_child)]] + } + + # Remove stale "package ifneeded" data for non-loaded packages. + # - Not for loaded packages, because "package forget" erases + # data from "package provide" as well as "package ifneeded". + # - This is OK because the script cannot reload any version of + # the package unless it first does "package forget". + foreach pkg [::interp eval $child {package names}] { + if {[::interp eval $child [list package provide $pkg]] eq ""} { + ::interp eval $child [list package forget $pkg] + } } } + return } } } @@ -239,17 +260,17 @@ proc ::safe::interpConfigure {args} { # # safe::InterpCreate : doing the real job # -# This procedure creates a safe slave and initializes it with the safe +# This procedure creates a safe interpreter and initializes it with the safe # base aliases. -# NB: slave name must be simple alphanumeric string, no spaces, no (), no +# NB: child name must be simple alphanumeric string, no spaces, no (), no # {},... {because the state array is stored as part of the name} # -# Returns the slave name. +# Returns the child name. # # Optional Arguments : -# + slave name : if empty, generated name will be used +# + child name : if empty, generated name will be used # + access_path: path list controlling where load/source can occur, -# if empty: the master auto_path will be used. +# if empty: the parent auto_path will be used. # + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx) # if 1 :static packages are ok. # + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub) @@ -257,35 +278,37 @@ proc ::safe::interpConfigure {args} { # use the full name and no indent so auto_mkIndex can find us proc ::safe::InterpCreate { - slave + child access_path staticsok nestedok deletehook } { - # Create the slave. - if {$slave ne ""} { - ::interp create -safe $slave + # Create the child. + # If evaluated in ::safe, the interpreter command for foo is ::foo; + # but for foo::bar is safe::foo::bar. So evaluate in :: instead. + if {$child ne ""} { + namespace eval :: [list ::interp create -safe $child] } else { - # empty argument: generate slave name - set slave [::interp create -safe] + # empty argument: generate child name + set child [::interp create -safe] } - Log $slave "Created" NOTICE + Log $child "Created" NOTICE - # Initialize it. (returns slave name) - InterpInit $slave $access_path $staticsok $nestedok $deletehook + # Initialize it. (returns child name) + InterpInit $child $access_path $staticsok $nestedok $deletehook } # # InterpSetConfig (was setAccessPath) : -# Sets up slave virtual auto_path and corresponding structure within -# the master. Also sets the tcl_library in the slave to be the first +# Sets up child virtual auto_path and corresponding structure within +# the parent. Also sets the tcl_library in the child to be the first # directory in the path. -# NB: If you change the path after the slave has been initialized you -# probably need to call "auto_reset" in the slave in order that it gets +# NB: If you change the path after the child has been initialized you +# probably need to call "auto_reset" in the child in order that it gets # the right auto_index() array values. -proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { +proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook} { global auto_path # determine and store the access path if empty @@ -295,48 +318,48 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # Make sure that tcl_library is in auto_path and at the first # position (needed by setAccessPath) set where [lsearch -exact $access_path [info library]] - if {$where == -1} { + if {$where < 0} { # not found, add it. set access_path [linsert $access_path 0 [info library]] - Log $slave "tcl_library was not in auto_path,\ - added it to slave's access_path" NOTICE + Log $child "tcl_library was not in auto_path,\ + added it to child's access_path" NOTICE } elseif {$where != 0} { # not first, move it first set access_path [linsert \ [lreplace $access_path $where $where] \ 0 [info library]] - Log $slave "tcl_libray was not in first in auto_path,\ - moved it to front of slave's access_path" NOTICE + Log $child "tcl_libray was not in first in auto_path,\ + moved it to front of child's access_path" NOTICE } # Add 1st level sub dirs (will searched by auto loading from tcl - # code in the slave using glob and thus fail, so we add them here + # code in the child using glob and thus fail, so we add them here # so by default it works the same). set access_path [AddSubDirs $access_path] } - Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\ + Log $child "Setting accessPath=($access_path) staticsok=$staticsok\ nestedok=$nestedok deletehook=($deletehook)" NOTICE - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $child] state # clear old autopath if it existed # build new one # Extend the access list with the paths used to look for Tcl Modules. # We save the virtual form separately as well, as syncing it with the - # slave has to be defered until the necessary commands are present for + # child has to be defered until the necessary commands are present for # setup. set norm_access_path {} - set slave_access_path {} + set child_access_path {} set map_access_path {} set remap_access_path {} - set slave_tm_path {} + set child_tm_path {} set i 0 foreach dir $access_path { set token [PathToken $i] - lappend slave_access_path $token + lappend child_access_path $token lappend map_access_path $token $dir lappend remap_access_path $dir $token lappend norm_access_path [file normalize $dir] @@ -344,6 +367,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { } set morepaths [::tcl::tm::list] + set firstpass 1 while {[llength $morepaths]} { set addpaths $morepaths set morepaths {} @@ -352,16 +376,27 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # Prevent the addition of dirs on the tm list to the # result if they are already known. if {[dict exists $remap_access_path $dir]} { + if {$firstpass} { + # $dir is in [::tcl::tm::list] and belongs in the child_tm_path. + # Later passes handle subdirectories, which belong in the + # access path but not in the module path. + lappend child_tm_path [dict get $remap_access_path $dir] + } continue } set token [PathToken $i] lappend access_path $dir - lappend slave_access_path $token + lappend child_access_path $token lappend map_access_path $token $dir lappend remap_access_path $dir $token lappend norm_access_path [file normalize $dir] - lappend slave_tm_path $token + if {$firstpass} { + # $dir is in [::tcl::tm::list] and belongs in the child_tm_path. + # Later passes handle subdirectories, which belong in the + # access path but not in the module path. + lappend child_tm_path $token + } incr i # [Bug 2854929] @@ -372,19 +407,21 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # subdirectories. lappend morepaths {*}[glob -nocomplain -directory $dir -type d *] } + set firstpass 0 } set state(access_path) $access_path set state(access_path,map) $map_access_path set state(access_path,remap) $remap_access_path set state(access_path,norm) $norm_access_path - set state(access_path,slave) $slave_access_path - set state(tm_path_slave) $slave_tm_path + set state(access_path,child) $child_access_path + set state(tm_path_child) $child_tm_path set state(staticsok) $staticsok set state(nestedok) $nestedok set state(cleanupHook) $deletehook - SyncAccessPath $slave + SyncAccessPath $child + return } # @@ -392,11 +429,12 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # FindInAccessPath: # Search for a real directory and returns its virtual Id (including the # "$") -proc ::safe::interpFindInAccessPath {slave path} { - namespace upvar ::safe S$slave state +proc ::safe::interpFindInAccessPath {child path} { + CheckInterp $child + namespace upvar ::safe [VarName $child] state if {![dict exists $state(access_path,remap) $path]} { - return -code error "$path not found in access path $access_path" + return -code error "$path not found in access path" } return [dict get $state(access_path,remap) $path] @@ -406,10 +444,11 @@ proc ::safe::interpFindInAccessPath {slave path} { # addToAccessPath: # add (if needed) a real directory to access path and return its # virtual token (including the "$"). -proc ::safe::interpAddToAccessPath {slave path} { +proc ::safe::interpAddToAccessPath {child path} { # first check if the directory is already in there # (inlined interpFindInAccessPath). - namespace upvar ::safe S$slave state + CheckInterp $child + namespace upvar ::safe [VarName $child] state if {[dict exists $state(access_path,remap) $path]} { return [dict get $state(access_path,remap) $path] @@ -419,12 +458,12 @@ proc ::safe::interpAddToAccessPath {slave path} { set token [PathToken [llength $state(access_path)]] lappend state(access_path) $path - lappend state(access_path,slave) $token + lappend state(access_path,child) $token lappend state(access_path,map) $token $path lappend state(access_path,remap) $path $token lappend state(access_path,norm) [file normalize $path] - SyncAccessPath $slave + SyncAccessPath $child return $token } @@ -432,25 +471,25 @@ proc ::safe::interpAddToAccessPath {slave path} { # interpreter. It is useful when you want to install the safe base aliases # into a preexisting safe interpreter. proc ::safe::InterpInit { - slave + child access_path staticsok nestedok deletehook } { # Configure will generate an access_path when access_path is empty. - InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook + InterpSetConfig $child $access_path $staticsok $nestedok $deletehook # NB we need to add [namespace current], aliases are always absolute # paths. - # These aliases let the slave load files to define new commands - # This alias lets the slave use the encoding names, convertfrom, + # These aliases let the child load files to define new commands + # This alias lets the child use the encoding names, convertfrom, # convertto, and system, but not "encoding system <name>" to set the # system encoding. # Handling Tcl Modules, we need a restricted form of Glob. # This alias interposes on the 'exit' command and cleanly terminates - # the slave. + # the child. foreach {command alias} { source AliasSource @@ -458,60 +497,60 @@ proc ::safe::InterpInit { exit interpDelete glob AliasGlob } { - ::interp alias $slave $command {} [namespace current]::$alias $slave + ::interp alias $child $command {} [namespace current]::$alias $child } # UGLY POINT! These commands are safe (they're ensembles with unsafe # subcommands), but is assumed to not be by existing policies so it is # hidden by default. Hack it... foreach command {encoding file} { - ::interp alias $slave $command {} interp invokehidden $slave $command + ::interp alias $child $command {} interp invokehidden $child $command } - # This alias lets the slave have access to a subset of the 'file' + # This alias lets the child have access to a subset of the 'file' # command functionality. foreach subcommand {dirname extension rootname tail} { - ::interp alias $slave ::tcl::file::$subcommand {} \ - ::safe::AliasFileSubcommand $slave $subcommand + ::interp alias $child ::tcl::file::$subcommand {} \ + ::safe::AliasFileSubcommand $child $subcommand } # Subcommand of 'encoding' that has special handling; [encoding system] is # OK provided it has no other arguments passed to it. - ::interp alias $slave ::tcl::encoding::system {} \ - ::safe::AliasEncodingSystem $slave + ::interp alias $child ::tcl::encoding::system {} \ + ::safe::AliasEncodingSystem $child # Subcommands of info - ::interp alias $slave ::tcl::info::nameofexecutable {} \ - ::safe::AliasExeName $slave + ::interp alias $child ::tcl::info::nameofexecutable {} \ + ::safe::AliasExeName $child - # The allowed slave variables already have been set by Tcl_MakeSafe(3) + # The allowed child variables already have been set by Tcl_MakeSafe(3) - # Source init.tcl and tm.tcl into the slave, to get auto_load and + # Source init.tcl and tm.tcl into the child, to get auto_load and # other procedures defined: - if {[catch {::interp eval $slave { + if {[catch {::interp eval $child { source [file join $tcl_library init.tcl] }} msg opt]} { - Log $slave "can't source init.tcl ($msg)" - return -options $opt "can't source init.tcl into slave $slave ($msg)" + Log $child "can't source init.tcl ($msg)" + return -options $opt "can't source init.tcl into child $child ($msg)" } - if {[catch {::interp eval $slave { + if {[catch {::interp eval $child { source [file join $tcl_library tm.tcl] }} msg opt]} { - Log $slave "can't source tm.tcl ($msg)" - return -options $opt "can't source tm.tcl into slave $slave ($msg)" + Log $child "can't source tm.tcl ($msg)" + return -options $opt "can't source tm.tcl into child $child ($msg)" } # Sync the paths used to search for Tcl modules. This can be done only # now, after tm.tcl was loaded. - namespace upvar ::safe S$slave state - if {[llength $state(tm_path_slave)] > 0} { - ::interp eval $slave [list \ - ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]] + namespace upvar ::safe [VarName $child] state + if {[llength $state(tm_path_child)] > 0} { + ::interp eval $child [list \ + ::tcl::tm::add {*}[lreverse $state(tm_path_child)]] } - return $slave + return $child } # Add (only if needed, avoid duplicates) 1 level of sub directories to an @@ -537,15 +576,30 @@ proc ::safe::AddSubDirs {pathList} { return $res } -# This procedure deletes a safe slave managed by Safe Tcl and cleans up -# associated state: - -proc ::safe::interpDelete {slave} { - Log $slave "About to delete" NOTICE - - namespace upvar ::safe S$slave state +# This procedure deletes a safe interpreter managed by Safe Tcl and cleans up +# associated state. +# - The command will also delete non-Safe-Base interpreters. +# - This is regrettable, but to avoid breaking existing code this should be +# amended at the next major revision by uncommenting "CheckInterp". + +proc ::safe::interpDelete {child} { + Log $child "About to delete" NOTICE + + # CheckInterp $child + namespace upvar ::safe [VarName $child] state + + # When an interpreter is deleted with [interp delete], any sub-interpreters + # are deleted automatically, but this leaves behind their data in the Safe + # Base. To clean up properly, we call safe::interpDelete recursively on each + # Safe Base sub-interpreter, so each one is deleted cleanly and not by + # the automatic mechanism built into [interp delete]. + foreach sub [interp children $child] { + if {[info exists ::safe::[VarName [list $child $sub]]]} { + ::safe::interpDelete [list $child $sub] + } + } - # If the slave has a cleanup hook registered, call it. Check the + # If the child has a cleanup hook registered, call it. Check the # existance because we might be called to delete an interp which has # not been registered with us at all @@ -556,14 +610,14 @@ proc ::safe::interpDelete {slave} { # we'll loop unset state(cleanupHook) try { - {*}$hook $slave + {*}$hook $child } on error err { - Log $slave "Delete hook error ($err)" + Log $child "Delete hook error ($err)" } } } - # Discard the global array of state associated with the slave, and + # Discard the global array of state associated with the child, and # delete the interpreter. if {[info exists state]} { @@ -572,9 +626,9 @@ proc ::safe::interpDelete {slave} { # if we have been called twice, the interp might have been deleted # already - if {[::interp exists $slave]} { - ::interp delete $slave - Log $slave "Deleted" NOTICE + if {[::interp exists $child]} { + ::interp delete $child + Log $child "Deleted" NOTICE } return @@ -600,9 +654,9 @@ proc ::safe::setLogCmd {args} { } else { # Activate logging, define proper command. - proc ::safe::Log {slave msg {type ERROR}} { + proc ::safe::Log {child msg {type ERROR}} { variable Log - {*}$Log "$type for slave $slave : $msg" + {*}$Log "$type for child $child : $msg" return } } @@ -611,24 +665,24 @@ proc ::safe::setLogCmd {args} { # ------------------- END OF PUBLIC METHODS ------------ # -# Sets the slave auto_path to the master recorded value. Also sets +# Sets the child auto_path to the parent recorded value. Also sets # tcl_library to the first token of the virtual path. # -proc ::safe::SyncAccessPath {slave} { - namespace upvar ::safe S$slave state +proc ::safe::SyncAccessPath {child} { + namespace upvar ::safe [VarName $child] state - set slave_access_path $state(access_path,slave) - ::interp eval $slave [list set auto_path $slave_access_path] + set child_access_path $state(access_path,child) + ::interp eval $child [list set auto_path $child_access_path] - Log $slave "auto_path in $slave has been set to $slave_access_path"\ + Log $child "auto_path in $child has been set to $child_access_path"\ NOTICE # This code assumes that info library is the first element in the # list of auto_path's. See -> InterpSetConfig for the code which # ensures this condition. - ::interp eval $slave [list \ - set tcl_library [lindex $slave_access_path 0]] + ::interp eval $child [list \ + set tcl_library [lindex $child_access_path 0]] } # Returns the virtual token for directory number N. @@ -641,8 +695,8 @@ proc ::safe::PathToken {n} { # # translate virtual path into real path # -proc ::safe::TranslatePath {slave path} { - namespace upvar ::safe S$slave state +proc ::safe::TranslatePath {child path} { + namespace upvar ::safe [VarName $child] state # somehow strip the namespaces 'functionality' out (the danger is that # we would strip valid macintosh "../" queries... : @@ -657,7 +711,7 @@ proc ::safe::TranslatePath {slave path} { # file name control (limit access to files/resources that should be a # valid tcl source file) -proc ::safe::CheckFileName {slave file} { +proc ::safe::CheckFileName {child file} { # This used to limit what can be sourced to ".tcl" and forbid files # with more than 1 dot and longer than 14 chars, but I changed that # for 8.4 as a safe interp has enough internal protection already to @@ -678,17 +732,17 @@ proc ::safe::CheckFileName {slave file} { # interpreters that are *almost* safe. In particular, it just acts to # prevent discovery of what home directories exist. -proc ::safe::AliasFileSubcommand {slave subcommand name} { +proc ::safe::AliasFileSubcommand {child subcommand name} { if {[string match ~* $name]} { set name ./$name } - tailcall ::interp invokehidden $slave tcl:file:$subcommand $name + tailcall ::interp invokehidden $child tcl:file:$subcommand $name } # AliasGlob is the target of the "glob" alias in safe interpreters. -proc ::safe::AliasGlob {slave args} { - Log $slave "GLOB ! $args" NOTICE +proc ::safe::AliasGlob {child args} { + Log $child "GLOB ! $args" NOTICE set cmd {} set at 0 array set got { @@ -710,11 +764,15 @@ proc ::safe::AliasGlob {slave args} { while {$at < [llength $args]} { switch -glob -- [set opt [lindex $args $at]] { - -nocomplain - -- - -join - -tails { + -nocomplain - -- - -tails { lappend cmd $opt set got($opt) 1 incr at } + -join { + set got($opt) 1 + incr at + } -types - -type { lappend cmd -types [lindex $args [incr at]] incr at @@ -728,15 +786,8 @@ 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'" + Log $child "Safe base rejecting glob option '$opt'" return -code error "Safe base rejecting glob option '$opt'" } default { @@ -747,73 +798,116 @@ proc ::safe::AliasGlob {slave args} { } # Get the real path from the virtual one and check that the path is in the - # access path of that slave. Done after basic argument processing so that + # access path of that child. Done after basic argument processing so that # we know if -nocomplain is set. if {$got(-directory)} { try { - set dir [TranslatePath $slave $virtualdir] - DirInAccessPath $slave $dir + set dir [TranslatePath $child $virtualdir] + DirInAccessPath $child $dir } on error msg { - Log $slave $msg + Log $child $msg 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 $child {option -directory must be supplied} + if {$got(-nocomplain)} return + return -code error "permission denied" } - # 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 . - } 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] \ + foreach d [glob -directory [TranslatePath $child $virtualdir] \ -types d -tails *] { catch { - DirInAccessPath $slave \ - [TranslatePath $slave [file join $virtualdir $d]] + DirInAccessPath $child \ + [TranslatePath $child [file join $virtualdir $d]] lappend cmd [file join $d $thefile] set mapped 1 } } 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 \ + DirInAccessPath $child [TranslatePath $child \ [file join $virtualdir $thedir]] } on error msg { - Log $slave $msg + Log $child $msg if {$got(-nocomplain)} continue return -code error "permission denied" } lappend cmd $opt } - Log $slave "GLOB = $cmd" NOTICE + Log $child "GLOB = $cmd" NOTICE if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} { return } try { - set entries [::interp invokehidden $slave glob {*}$cmd] + # >>>>>>>>>> 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 $child glob {*}$cmd] } on error msg { - Log $slave $msg + # This is the only place that a call with -nocomplain and no invalid + # "dash-options" can return an error. + Log $child $msg return -code error "script error" } - Log $slave "GLOB < $entries" NOTICE + Log $child "GLOB < $entries" NOTICE - # Translate path back to what the slave should see. + # Translate path back to what the child should see. set res {} set l [string length $dir] foreach p $entries { @@ -823,13 +917,13 @@ proc ::safe::AliasGlob {slave args} { lappend res $p } - Log $slave "GLOB > $res" NOTICE + Log $child "GLOB > $res" NOTICE return $res } # AliasSource is the target of the "source" alias in safe interpreters. -proc ::safe::AliasSource {slave args} { +proc ::safe::AliasSource {child args} { set argc [llength $args] # Extended for handling of Tcl Modules to allow not only "source # filename", but "source -encoding E filename" as well. @@ -838,68 +932,68 @@ proc ::safe::AliasSource {slave args} { set encoding [lindex $args 1] set at 2 if {$encoding eq "identity"} { - Log $slave "attempt to use the identity encoding" + Log $child "attempt to use the identity encoding" return -code error "permission denied" } } else { set at 0 - set encoding {} + set encoding utf-8 } if {$argc != 1} { set msg "wrong # args: should be \"source ?-encoding E? fileName\"" - Log $slave "$msg ($args)" + Log $child "$msg ($args)" return -code error $msg } set file [lindex $args $at] # get the real path from the virtual one. if {[catch { - set realfile [TranslatePath $slave $file] + set realfile [TranslatePath $child $file] } msg]} { - Log $slave $msg + Log $child $msg return -code error "permission denied" } - # check that the path is in the access path of that slave + # check that the path is in the access path of that child if {[catch { - FileInAccessPath $slave $realfile + FileInAccessPath $child $realfile } msg]} { - Log $slave $msg + Log $child $msg return -code error "permission denied" } - # do the checks on the filename : + # Check that the filename exists and is readable. If it is not, deliver + # this -errorcode so that caller in tclPkgUnknown does not write a message + # to tclLog. Has no effect on other callers of ::source, which are in + # "package ifneeded" scripts. if {[catch { - CheckFileName $slave $realfile + CheckFileName $child $realfile } msg]} { - Log $slave "$realfile:$msg" - return -code error $msg + Log $child "$realfile:$msg" + return -code error -errorcode {POSIX EACCES} $msg } # Passed all the tests, lets source it. Note that we do this all manually - # because we want to control [info script] in the slave so information + # because we want to control [info script] in the child so information # doesn't leak so much. [Bug 2913625] - set old [::interp eval $slave {info script}] + set old [::interp eval $child {info script}] set replacementMsg "script error" set code [catch { set f [open $realfile] - fconfigure $f -eofchar \032 - if {$encoding ne ""} { - fconfigure $f -encoding $encoding - } + fconfigure $f -encoding $encoding -eofchar \032 set contents [read $f] close $f - ::interp eval $slave [list info script $file] + ::interp eval $child [list info script $file] } msg opt] if {$code == 0} { - set code [catch {::interp eval $slave $contents} msg opt] + set code [catch {::interp eval $child $contents} msg opt] set replacementMsg $msg } - catch {interp eval $slave [list info script $old]} + catch {interp eval $child [list info script $old]} # Note that all non-errors are fine result codes from [source], so we must # take a little care to do it properly. [Bug 2923613] if {$code == 1} { - Log $slave $msg + Log $child $msg return -code error $replacementMsg } return -code $code -options $opt $msg @@ -907,18 +1001,18 @@ proc ::safe::AliasSource {slave args} { # AliasLoad is the target of the "load" alias in safe interpreters. -proc ::safe::AliasLoad {slave file args} { +proc ::safe::AliasLoad {child file args} { set argc [llength $args] if {$argc > 2} { set msg "load error: too many arguments" - Log $slave "$msg ($argc) {$file $args}" + Log $child "$msg ($argc) {$file $args}" return -code error $msg } # package name (can be empty if file is not). set package [lindex $args 0] - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $child] state # Determine where to load. load use a relative interp path and {} # means self, so we can directly and safely use passed arg. @@ -927,7 +1021,7 @@ proc ::safe::AliasLoad {slave file args} { # we will try to load into a sub sub interp; check that we want to # authorize that. if {!$state(nestedok)} { - Log $slave "loading to a sub interp (nestedok)\ + Log $child "loading to a sub interp (nestedok)\ disabled (trying to load $package to $target)" return -code error "permission denied (nested load)" } @@ -938,11 +1032,11 @@ proc ::safe::AliasLoad {slave file args} { # static package loading if {$package eq ""} { set msg "load error: empty filename and no package name" - Log $slave $msg + Log $child $msg return -code error $msg } if {!$state(staticsok)} { - Log $slave "static packages loading disabled\ + Log $child "static packages loading disabled\ (trying to load $package to $target)" return -code error "permission denied (static package)" } @@ -951,36 +1045,43 @@ proc ::safe::AliasLoad {slave file args} { # get the real path from the virtual one. try { - set file [TranslatePath $slave $file] + set file [TranslatePath $child $file] } on error msg { - Log $slave $msg + Log $child $msg return -code error "permission denied" } # check the translated path try { - FileInAccessPath $slave $file + FileInAccessPath $child $file } on error msg { - Log $slave $msg + Log $child $msg return -code error "permission denied (path)" } } try { - return [::interp invokehidden $slave load $file $package $target] + return [::interp invokehidden $child load $file $package $target] } on error msg { - Log $slave $msg + # Some packages return no error message. + set msg0 "load of binary library for package $package failed" + if {$msg eq {}} { + set msg $msg0 + } else { + set msg "$msg0: $msg" + } + Log $child $msg return -code error $msg } } # FileInAccessPath raises an error if the file is not found in the list of -# directories contained in the (master side recorded) slave's access path. +# directories contained in the (parent side recorded) child's access path. # the security here relies on "file dirname" answering the proper # result... needs checking ? -proc ::safe::FileInAccessPath {slave file} { - namespace upvar ::safe S$slave state +proc ::safe::FileInAccessPath {child file} { + namespace upvar ::safe [VarName $child] state set access_path $state(access_path) if {[file isdirectory $file]} { @@ -992,14 +1093,14 @@ proc ::safe::FileInAccessPath {slave file} { # potential pathname anomalies. set norm_parent [file normalize $parent] - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $child] state if {$norm_parent ni $state(access_path,norm)} { return -code error "\"$file\": not in access_path" } } -proc ::safe::DirInAccessPath {slave dir} { - namespace upvar ::safe S$slave state +proc ::safe::DirInAccessPath {child dir} { + namespace upvar ::safe [VarName $child] state set access_path $state(access_path) if {[file isfile $dir]} { @@ -1010,7 +1111,7 @@ proc ::safe::DirInAccessPath {slave dir} { # potential pathname anomalies. set norm_dir [file normalize $dir] - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $child] state if {$norm_dir ni $state(access_path,norm)} { return -code error "\"$dir\": not in access_path" } @@ -1019,35 +1120,87 @@ proc ::safe::DirInAccessPath {slave dir} { # This procedure is used to report an attempt to use an unsafe member of an # ensemble command. -proc ::safe::BadSubcommand {slave command subcommand args} { +proc ::safe::BadSubcommand {child command subcommand args} { set msg "not allowed to invoke subcommand $subcommand of $command" - Log $slave $msg + Log $child $msg return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg } # AliasEncodingSystem is the target of the "encoding system" alias in safe # interpreters. -proc ::safe::AliasEncodingSystem {slave args} { +proc ::safe::AliasEncodingSystem {child args} { try { - # Must not pass extra arguments; safe slaves may not set the system - # encoding but they may read it. + # Must not pass extra arguments; safe interpreters may not set the + # system encoding but they may read it. if {[llength $args]} { return -code error -errorcode {TCL WRONGARGS} \ "wrong # args: should be \"encoding system\"" } } on error {msg options} { - Log $slave $msg + Log $child $msg return -options $options $msg } - tailcall ::interp invokehidden $slave tcl:encoding:system + tailcall ::interp invokehidden $child tcl:encoding:system } # Various minor hiding of platform features. [Bug 2913625] -proc ::safe::AliasExeName {slave} { +proc ::safe::AliasExeName {child} { return "" } +# ------------------------------------------------------------------------------ +# Using Interpreter Names with Namespace Qualifiers +# ------------------------------------------------------------------------------ +# (1) We wish to preserve compatibility with existing code, in which Safe Base +# interpreter names have no namespace qualifiers. +# (2) safe::interpCreate and the rest of the Safe Base previously could not +# accept namespace qualifiers in an interpreter name. +# (3) The interp command will accept namespace qualifiers in an interpreter +# name, but accepts distinct interpreters that will have the same command +# name (e.g. foo, ::foo, and :::foo) (bug 66c2e8c974). +# (4) To satisfy these constraints, Safe Base interpreter names will be fully +# qualified namespace names with no excess colons and with the leading "::" +# omitted. +# (5) Trailing "::" implies a namespace tail {}, which interp reads as {{}}. +# Reject such names. +# (6) We could: +# (a) EITHER reject usable but non-compliant names (e.g. excess colons) in +# interpCreate, interpInit; +# (b) OR accept such names and then translate to a compliant name in every +# command. +# The problem with (b) is that the user will expect to use the name with the +# interp command and will find that it is not recognised. +# E.g "interpCreate ::foo" creates interpreter "foo", and the user's name +# "::foo" works with all the Safe Base commands, but "interp eval ::foo" +# fails. +# So we choose (a). +# (7) The command +# namespace upvar ::safe S$child state +# becomes +# namespace upvar ::safe [VarName $child] state +# ------------------------------------------------------------------------------ + +proc ::safe::RejectExcessColons {child} { + set stripped [regsub -all -- {:::*} $child ::] + if {[string range $stripped end-1 end] eq {::}} { + return -code error {interpreter name must not end in "::"} + } + if {$stripped ne $child} { + set msg {interpreter name has excess colons in namespace separators} + return -code error $msg + } + if {[string range $stripped 0 1] eq {::}} { + return -code error {interpreter name must not begin "::"} + } + return +} + +proc ::safe::VarName {child} { + # return S$child + return S[string map {:: @N @ @A} $child] +} + proc ::safe::Setup {} { #### # @@ -1057,7 +1210,7 @@ proc ::safe::Setup {} { # Share the descriptions set temp [::tcl::OptKeyRegister { - {-accessPath -list {} "access path for the slave"} + {-accessPath -list {} "access path for the child"} {-noStatics "prevent loading of statically linked pkgs"} {-statics true "loading of statically linked pkgs"} {-nestedLoadOk "allow nested loading"} @@ -1065,18 +1218,18 @@ proc ::safe::Setup {} { {-deleteHook -script {} "delete hook"} }] - # create case (slave is optional) + # create case (child is optional) ::tcl::OptKeyRegister { - {?slave? -name {} "name of the slave (optional)"} + {?child? -name {} "name of the child (optional)"} } ::safe::interpCreate # adding the flags sub programs to the command program (relying on Opt's # internal implementation details) lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp) - # init and configure (slave is needed) + # init and configure (child is needed) ::tcl::OptKeyRegister { - {slave -name {} "name of the slave"} + {child -name {} "name of the child"} } ::safe::interpIC # adding the flags sub programs to the command program (relying on Opt's @@ -1106,20 +1259,20 @@ namespace eval ::safe { # Log command, set via 'setLogCmd'. Logging is disabled when empty. variable Log {} - # The package maintains a state array per slave interp under its + # The package maintains a state array per child interp under its # control. The name of this array is S<interp-name>. This array is # brought into scope where needed, using 'namespace upvar'. The S - # prefix is used to avoid that a slave interp called "Log" smashes + # prefix is used to avoid that a child interp called "Log" smashes # the "Log" variable. # # The array's elements are: # - # access_path : List of paths accessible to the slave. + # access_path : List of paths accessible to the child. # access_path,norm : Ditto, in normalized form. - # access_path,slave : Ditto, as the path tokens as seen by the slave. + # access_path,child : Ditto, as the path tokens as seen by the child. # access_path,map : dict ( token -> path ) # access_path,remap : dict ( path -> token ) - # tm_path_slave : List of TM root directories, as tokens seen by the slave. + # tm_path_child : List of TM root directories, as tokens seen by the child. # staticsok : Value of option -statics # nestedok : Value of option -nested # cleanupHook : Value of option -deleteHook diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index c894ff1..4df25e4 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -640,7 +640,7 @@ namespace eval tcltest { proc IsVerbose {level} { variable Option - return [expr {[lsearch -exact $Option(-verbose) $level] != -1}] + return [expr {[lsearch -exact $Option(-verbose) $level] >= 0}] } # Default verbosity is to show bodies of failed tests @@ -2798,7 +2798,6 @@ proc tcltest::runAllTests { {shell ""} } { variable numTests variable failFiles variable DefaultValue - set failFilesAccum {} FillFilesExisted if {[llength [info level 0]] == 1} { @@ -2854,8 +2853,18 @@ proc tcltest::runAllTests { {shell ""} } { flush [outputChannel] if {[singleProcess]} { - incr numTestFiles - uplevel 1 [list ::source $file] + if {[catch { + incr numTestFiles + uplevel 1 [list ::source $file] + } msg]} { + puts [outputChannel] "Test file error: $msg" + # append the name of the test to a list to be reported + # later + lappend testFileFailures $file + } + if {$numTests(Failed) > 0} { + set failFilesSet 1 + } } else { # Pass along our configuration to the child processes. # EXCEPT for the -outfile, because the parent process @@ -2888,7 +2897,7 @@ proc tcltest::runAllTests { {shell ""} } { } if {$Failed > 0} { lappend failFiles $testFile - lappend failFilesAccum $testFile + set failFilesSet 1 } } elseif {[regexp [join { {^Number of tests skipped } @@ -2935,7 +2944,7 @@ proc tcltest::runAllTests { {shell ""} } { puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } - return [expr {[info exists testFileFailures] || [llength $failFilesAccum]}] + return [expr {[info exists testFileFailures] || [info exists failFilesSet]}] } ##################################################################### @@ -3107,7 +3116,7 @@ proc tcltest::removeFile {name {directory ""}} { set fullName [file join $directory $name] DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName" set idx [lsearch -exact $filesMade $fullName] - if {$idx == -1} { + if {$idx < 0} { DebugDo 1 { Warn "removeFile removing \"$fullName\":\n not created by makeFile" } @@ -3184,7 +3193,7 @@ proc tcltest::removeDirectory {name {directory ""}} { DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName" set idx [lsearch -exact $filesMade $fullName] set filesMade [lreplace $filesMade $idx $idx] - if {$idx == -1} { + if {$idx < 0} { DebugDo 1 { Warn "removeDirectory removing \"$fullName\":\n not created\ by makeDirectory" @@ -3233,8 +3242,8 @@ proc tcltest::viewFile {name {directory ""}} { # procedures that are supposed to accept strings with embedded NULL # bytes. # 2. Confirm that a string result has a certain pattern of bytes, for -# instance to confirm that "\xe0\0" in a Tcl script is stored -# internally in UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80". +# instance to confirm that "\xE0\0" in a Tcl script is stored +# internally in UTF-8 as the sequence of bytes "\xC3\xA0\xC0\x80". # # Generally, it's a bad idea to examine the bytes in a Tcl string or to # construct improperly formed strings in this manner, because it involves diff --git a/library/tm.tcl b/library/tm.tcl index 0ed3f1a..3c0ec22 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 @@ -266,7 +267,7 @@ proc ::tcl::tm::UnknownHandler {original name args} { # of the package file is the last element in the list. package ifneeded $pkgname $pkgversion \ - "[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]" + "[::list package provide $pkgname $pkgversion];[::list source $file]" # We abort in this unknown handler only if we got a # satisfying candidate for the requested package. diff --git a/library/tzdata/Africa/Algiers b/library/tzdata/Africa/Algiers index fe4de22..b26d31c 100644 --- a/library/tzdata/Africa/Algiers +++ b/library/tzdata/Africa/Algiers @@ -2,7 +2,7 @@ set TZData(:Africa/Algiers) { {-9223372036854775808 732 0 LMT} - {-2486679072 561 0 PMT} + {-2486592732 561 0 PMT} {-1855958961 0 0 WET} {-1689814800 3600 1 WEST} {-1680397200 0 0 WET} diff --git a/library/tzdata/Africa/Casablanca b/library/tzdata/Africa/Casablanca index 05ae49f..cb60740 100644 --- a/library/tzdata/Africa/Casablanca +++ b/library/tzdata/Africa/Casablanca @@ -66,7 +66,7 @@ set TZData(:Africa/Casablanca) { {1648346400 0 1 +01} {1651975200 3600 0 +01} {1679191200 0 1 +01} - {1682215200 3600 0 +01} + {1682820000 3600 0 +01} {1710036000 0 1 +01} {1713060000 3600 0 +01} {1740276000 0 1 +01} @@ -82,7 +82,7 @@ set TZData(:Africa/Casablanca) { {1893290400 0 1 +01} {1896919200 3600 0 +01} {1924135200 0 1 +01} - {1927159200 3600 0 +01} + {1927764000 3600 0 +01} {1954980000 0 1 +01} {1958004000 3600 0 +01} {1985220000 0 1 +01} @@ -98,7 +98,7 @@ set TZData(:Africa/Casablanca) { {2138234400 0 1 +01} {2141863200 3600 0 +01} {2169079200 0 1 +01} - {2172103200 3600 0 +01} + {2172708000 3600 0 +01} {2199924000 0 1 +01} {2202948000 3600 0 +01} {2230164000 0 1 +01} @@ -114,7 +114,7 @@ set TZData(:Africa/Casablanca) { {2383178400 0 1 +01} {2386807200 3600 0 +01} {2414023200 0 1 +01} - {2417047200 3600 0 +01} + {2417652000 3600 0 +01} {2444868000 0 1 +01} {2447892000 3600 0 +01} {2475108000 0 1 +01} @@ -130,7 +130,7 @@ set TZData(:Africa/Casablanca) { {2628122400 0 1 +01} {2631751200 3600 0 +01} {2658967200 0 1 +01} - {2661991200 3600 0 +01} + {2662596000 3600 0 +01} {2689812000 0 1 +01} {2692836000 3600 0 +01} {2720052000 0 1 +01} @@ -146,7 +146,7 @@ set TZData(:Africa/Casablanca) { {2873066400 0 1 +01} {2876695200 3600 0 +01} {2903911200 0 1 +01} - {2906935200 3600 0 +01} + {2907540000 3600 0 +01} {2934756000 0 1 +01} {2937780000 3600 0 +01} {2964996000 0 1 +01} @@ -162,7 +162,7 @@ set TZData(:Africa/Casablanca) { {3118010400 0 1 +01} {3121639200 3600 0 +01} {3148855200 0 1 +01} - {3151879200 3600 0 +01} + {3152484000 3600 0 +01} {3179700000 0 1 +01} {3182724000 3600 0 +01} {3209940000 0 1 +01} @@ -178,7 +178,7 @@ set TZData(:Africa/Casablanca) { {3362954400 0 1 +01} {3366583200 3600 0 +01} {3393799200 0 1 +01} - {3396823200 3600 0 +01} + {3397428000 3600 0 +01} {3424644000 0 1 +01} {3427668000 3600 0 +01} {3454884000 0 1 +01} @@ -188,13 +188,13 @@ set TZData(:Africa/Casablanca) { {3515968800 0 1 +01} {3519597600 3600 0 +01} {3546813600 0 1 +01} - {3549837600 3600 0 +01} + {3550442400 3600 0 +01} {3577658400 0 1 +01} {3580682400 3600 0 +01} {3607898400 0 1 +01} {3611527200 3600 0 +01} {3638743200 0 1 +01} - {3641767200 3600 0 +01} + {3642372000 3600 0 +01} {3669588000 0 1 +01} {3672612000 3600 0 +01} {3699828000 0 1 +01} diff --git a/library/tzdata/Africa/El_Aaiun b/library/tzdata/Africa/El_Aaiun index 8dbbdea..fd3e88f 100644 --- a/library/tzdata/Africa/El_Aaiun +++ b/library/tzdata/Africa/El_Aaiun @@ -55,7 +55,7 @@ set TZData(:Africa/El_Aaiun) { {1648346400 0 1 +01} {1651975200 3600 0 +01} {1679191200 0 1 +01} - {1682215200 3600 0 +01} + {1682820000 3600 0 +01} {1710036000 0 1 +01} {1713060000 3600 0 +01} {1740276000 0 1 +01} @@ -71,7 +71,7 @@ set TZData(:Africa/El_Aaiun) { {1893290400 0 1 +01} {1896919200 3600 0 +01} {1924135200 0 1 +01} - {1927159200 3600 0 +01} + {1927764000 3600 0 +01} {1954980000 0 1 +01} {1958004000 3600 0 +01} {1985220000 0 1 +01} @@ -87,7 +87,7 @@ set TZData(:Africa/El_Aaiun) { {2138234400 0 1 +01} {2141863200 3600 0 +01} {2169079200 0 1 +01} - {2172103200 3600 0 +01} + {2172708000 3600 0 +01} {2199924000 0 1 +01} {2202948000 3600 0 +01} {2230164000 0 1 +01} @@ -103,7 +103,7 @@ set TZData(:Africa/El_Aaiun) { {2383178400 0 1 +01} {2386807200 3600 0 +01} {2414023200 0 1 +01} - {2417047200 3600 0 +01} + {2417652000 3600 0 +01} {2444868000 0 1 +01} {2447892000 3600 0 +01} {2475108000 0 1 +01} @@ -119,7 +119,7 @@ set TZData(:Africa/El_Aaiun) { {2628122400 0 1 +01} {2631751200 3600 0 +01} {2658967200 0 1 +01} - {2661991200 3600 0 +01} + {2662596000 3600 0 +01} {2689812000 0 1 +01} {2692836000 3600 0 +01} {2720052000 0 1 +01} @@ -135,7 +135,7 @@ set TZData(:Africa/El_Aaiun) { {2873066400 0 1 +01} {2876695200 3600 0 +01} {2903911200 0 1 +01} - {2906935200 3600 0 +01} + {2907540000 3600 0 +01} {2934756000 0 1 +01} {2937780000 3600 0 +01} {2964996000 0 1 +01} @@ -151,7 +151,7 @@ set TZData(:Africa/El_Aaiun) { {3118010400 0 1 +01} {3121639200 3600 0 +01} {3148855200 0 1 +01} - {3151879200 3600 0 +01} + {3152484000 3600 0 +01} {3179700000 0 1 +01} {3182724000 3600 0 +01} {3209940000 0 1 +01} @@ -167,7 +167,7 @@ set TZData(:Africa/El_Aaiun) { {3362954400 0 1 +01} {3366583200 3600 0 +01} {3393799200 0 1 +01} - {3396823200 3600 0 +01} + {3397428000 3600 0 +01} {3424644000 0 1 +01} {3427668000 3600 0 +01} {3454884000 0 1 +01} @@ -177,13 +177,13 @@ set TZData(:Africa/El_Aaiun) { {3515968800 0 1 +01} {3519597600 3600 0 +01} {3546813600 0 1 +01} - {3549837600 3600 0 +01} + {3550442400 3600 0 +01} {3577658400 0 1 +01} {3580682400 3600 0 +01} {3607898400 0 1 +01} {3611527200 3600 0 +01} {3638743200 0 1 +01} - {3641767200 3600 0 +01} + {3642372000 3600 0 +01} {3669588000 0 1 +01} {3672612000 3600 0 +01} {3699828000 0 1 +01} diff --git a/library/tzdata/America/Dawson b/library/tzdata/America/Dawson index 1c827ff..c8e3f26 100644 --- a/library/tzdata/America/Dawson +++ b/library/tzdata/America/Dawson @@ -93,5 +93,6 @@ set TZData(:America/Dawson) { {1541322000 -28800 0 PST} {1552212000 -25200 1 PDT} {1572771600 -28800 0 PST} - {1583661600 -25200 0 MST} + {1583661600 -25200 1 PDT} + {1604217600 -25200 0 MST} } diff --git a/library/tzdata/America/Whitehorse b/library/tzdata/America/Whitehorse index da0c0f0..498a203 100644 --- a/library/tzdata/America/Whitehorse +++ b/library/tzdata/America/Whitehorse @@ -93,5 +93,6 @@ set TZData(:America/Whitehorse) { {1541322000 -28800 0 PST} {1552212000 -25200 1 PDT} {1572771600 -28800 0 PST} - {1583661600 -25200 0 MST} + {1583661600 -25200 1 PDT} + {1604217600 -25200 0 MST} } diff --git a/library/tzdata/Antarctica/Casey b/library/tzdata/Antarctica/Casey index aa37480..56935e3 100644 --- a/library/tzdata/Antarctica/Casey +++ b/library/tzdata/Antarctica/Casey @@ -9,4 +9,9 @@ set TZData(:Antarctica/Casey) { {1329843600 28800 0 +08} {1477065600 39600 0 +11} {1520701200 28800 0 +08} + {1538856000 39600 0 +11} + {1552752000 28800 0 +08} + {1570129200 39600 0 +11} + {1583596800 28800 0 +08} + {1601740860 39600 0 +11} } diff --git a/library/tzdata/Antarctica/Macquarie b/library/tzdata/Antarctica/Macquarie index 60bf7a6..e8ed043 100644 --- a/library/tzdata/Antarctica/Macquarie +++ b/library/tzdata/Antarctica/Macquarie @@ -93,5 +93,184 @@ set TZData(:Antarctica/Macquarie) { {1223136000 39600 1 AEDT} {1238860800 36000 0 AEST} {1254585600 39600 1 AEDT} - {1270310400 39600 0 +11} + {1262264400 39600 1 AEDT} + {1293800400 39600 0 AEST} + {1301760000 36000 0 AEST} + {1317484800 39600 1 AEDT} + {1333209600 36000 0 AEST} + {1349539200 39600 1 AEDT} + {1365264000 36000 0 AEST} + {1380988800 39600 1 AEDT} + {1396713600 36000 0 AEST} + {1412438400 39600 1 AEDT} + {1428163200 36000 0 AEST} + {1443888000 39600 1 AEDT} + {1459612800 36000 0 AEST} + {1475337600 39600 1 AEDT} + {1491062400 36000 0 AEST} + {1506787200 39600 1 AEDT} + {1522512000 36000 0 AEST} + {1538841600 39600 1 AEDT} + {1554566400 36000 0 AEST} + {1570291200 39600 1 AEDT} + {1586016000 36000 0 AEST} + {1601740800 39600 1 AEDT} + {1617465600 36000 0 AEST} + {1633190400 39600 1 AEDT} + {1648915200 36000 0 AEST} + {1664640000 39600 1 AEDT} + {1680364800 36000 0 AEST} + {1696089600 39600 1 AEDT} + {1712419200 36000 0 AEST} + {1728144000 39600 1 AEDT} + {1743868800 36000 0 AEST} + {1759593600 39600 1 AEDT} + {1775318400 36000 0 AEST} + {1791043200 39600 1 AEDT} + {1806768000 36000 0 AEST} + {1822492800 39600 1 AEDT} + {1838217600 36000 0 AEST} + {1853942400 39600 1 AEDT} + {1869667200 36000 0 AEST} + {1885996800 39600 1 AEDT} + {1901721600 36000 0 AEST} + {1917446400 39600 1 AEDT} + {1933171200 36000 0 AEST} + {1948896000 39600 1 AEDT} + {1964620800 36000 0 AEST} + {1980345600 39600 1 AEDT} + {1996070400 36000 0 AEST} + {2011795200 39600 1 AEDT} + {2027520000 36000 0 AEST} + {2043244800 39600 1 AEDT} + {2058969600 36000 0 AEST} + {2075299200 39600 1 AEDT} + {2091024000 36000 0 AEST} + {2106748800 39600 1 AEDT} + {2122473600 36000 0 AEST} + {2138198400 39600 1 AEDT} + {2153923200 36000 0 AEST} + {2169648000 39600 1 AEDT} + {2185372800 36000 0 AEST} + {2201097600 39600 1 AEDT} + {2216822400 36000 0 AEST} + {2233152000 39600 1 AEDT} + {2248876800 36000 0 AEST} + {2264601600 39600 1 AEDT} + {2280326400 36000 0 AEST} + {2296051200 39600 1 AEDT} + {2311776000 36000 0 AEST} + {2327500800 39600 1 AEDT} + {2343225600 36000 0 AEST} + {2358950400 39600 1 AEDT} + {2374675200 36000 0 AEST} + {2390400000 39600 1 AEDT} + {2406124800 36000 0 AEST} + {2422454400 39600 1 AEDT} + {2438179200 36000 0 AEST} + {2453904000 39600 1 AEDT} + {2469628800 36000 0 AEST} + {2485353600 39600 1 AEDT} + {2501078400 36000 0 AEST} + {2516803200 39600 1 AEDT} + {2532528000 36000 0 AEST} + {2548252800 39600 1 AEDT} + {2563977600 36000 0 AEST} + {2579702400 39600 1 AEDT} + {2596032000 36000 0 AEST} + {2611756800 39600 1 AEDT} + {2627481600 36000 0 AEST} + {2643206400 39600 1 AEDT} + {2658931200 36000 0 AEST} + {2674656000 39600 1 AEDT} + {2690380800 36000 0 AEST} + {2706105600 39600 1 AEDT} + {2721830400 36000 0 AEST} + {2737555200 39600 1 AEDT} + {2753280000 36000 0 AEST} + {2769609600 39600 1 AEDT} + {2785334400 36000 0 AEST} + {2801059200 39600 1 AEDT} + {2816784000 36000 0 AEST} + {2832508800 39600 1 AEDT} + {2848233600 36000 0 AEST} + {2863958400 39600 1 AEDT} + {2879683200 36000 0 AEST} + {2895408000 39600 1 AEDT} + {2911132800 36000 0 AEST} + {2926857600 39600 1 AEDT} + {2942582400 36000 0 AEST} + {2958912000 39600 1 AEDT} + {2974636800 36000 0 AEST} + {2990361600 39600 1 AEDT} + {3006086400 36000 0 AEST} + {3021811200 39600 1 AEDT} + {3037536000 36000 0 AEST} + {3053260800 39600 1 AEDT} + {3068985600 36000 0 AEST} + {3084710400 39600 1 AEDT} + {3100435200 36000 0 AEST} + {3116764800 39600 1 AEDT} + {3132489600 36000 0 AEST} + {3148214400 39600 1 AEDT} + {3163939200 36000 0 AEST} + {3179664000 39600 1 AEDT} + {3195388800 36000 0 AEST} + {3211113600 39600 1 AEDT} + {3226838400 36000 0 AEST} + {3242563200 39600 1 AEDT} + {3258288000 36000 0 AEST} + {3274012800 39600 1 AEDT} + {3289737600 36000 0 AEST} + {3306067200 39600 1 AEDT} + {3321792000 36000 0 AEST} + {3337516800 39600 1 AEDT} + {3353241600 36000 0 AEST} + {3368966400 39600 1 AEDT} + {3384691200 36000 0 AEST} + {3400416000 39600 1 AEDT} + {3416140800 36000 0 AEST} + {3431865600 39600 1 AEDT} + {3447590400 36000 0 AEST} + {3463315200 39600 1 AEDT} + {3479644800 36000 0 AEST} + {3495369600 39600 1 AEDT} + {3511094400 36000 0 AEST} + {3526819200 39600 1 AEDT} + {3542544000 36000 0 AEST} + {3558268800 39600 1 AEDT} + {3573993600 36000 0 AEST} + {3589718400 39600 1 AEDT} + {3605443200 36000 0 AEST} + {3621168000 39600 1 AEDT} + {3636892800 36000 0 AEST} + {3653222400 39600 1 AEDT} + {3668947200 36000 0 AEST} + {3684672000 39600 1 AEDT} + {3700396800 36000 0 AEST} + {3716121600 39600 1 AEDT} + {3731846400 36000 0 AEST} + {3747571200 39600 1 AEDT} + {3763296000 36000 0 AEST} + {3779020800 39600 1 AEDT} + {3794745600 36000 0 AEST} + {3810470400 39600 1 AEDT} + {3826195200 36000 0 AEST} + {3842524800 39600 1 AEDT} + {3858249600 36000 0 AEST} + {3873974400 39600 1 AEDT} + {3889699200 36000 0 AEST} + {3905424000 39600 1 AEDT} + {3921148800 36000 0 AEST} + {3936873600 39600 1 AEDT} + {3952598400 36000 0 AEST} + {3968323200 39600 1 AEDT} + {3984048000 36000 0 AEST} + {4000377600 39600 1 AEDT} + {4016102400 36000 0 AEST} + {4031827200 39600 1 AEDT} + {4047552000 36000 0 AEST} + {4063276800 39600 1 AEDT} + {4079001600 36000 0 AEST} + {4094726400 39600 1 AEDT} } diff --git a/library/tzdata/Europe/Budapest b/library/tzdata/Europe/Budapest index e660ad1..4b92c5f 100644 --- a/library/tzdata/Europe/Budapest +++ b/library/tzdata/Europe/Budapest @@ -2,17 +2,19 @@ set TZData(:Europe/Budapest) { {-9223372036854775808 4580 0 LMT} - {-2500938980 3600 0 CET} + {-2498260580 3600 0 CET} {-1693706400 7200 1 CEST} {-1680483600 3600 0 CET} {-1663455600 7200 1 CEST} {-1650150000 3600 0 CET} {-1640998800 3600 0 CET} - {-1633212000 7200 1 CEST} + {-1632006000 7200 1 CEST} {-1618700400 3600 0 CET} - {-1600466400 7200 1 CEST} - {-1581202800 3600 0 CET} - {-906771600 3600 0 CET} + {-1600470000 7200 1 CEST} + {-1587250800 3600 0 CET} + {-1569711600 7200 1 CEST} + {-1555196400 3600 0 CET} + {-906775200 3600 0 CET} {-857257200 3600 0 CET} {-844556400 7200 1 CEST} {-828226800 3600 0 CET} @@ -20,33 +22,32 @@ set TZData(:Europe/Budapest) { {-796777200 3600 0 CET} {-788922000 3600 0 CET} {-778471200 7200 1 CEST} - {-762660000 3600 0 CET} + {-762656400 3600 0 CET} {-749689200 7200 1 CEST} - {-733359600 3600 0 CET} + {-733276800 3600 0 CET} {-717634800 7200 1 CEST} {-701910000 3600 0 CET} {-686185200 7200 1 CEST} {-670460400 3600 0 CET} {-654130800 7200 1 CEST} {-639010800 3600 0 CET} - {-621990000 7200 1 CEST} - {-605660400 3600 0 CET} {-492656400 7200 1 CEST} {-481168800 3600 0 CET} - {-461120400 7200 1 CEST} - {-449632800 3600 0 CET} - {-428547600 7200 1 CEST} - {-418269600 3600 0 CET} - {-397094400 7200 1 CEST} + {-461199600 7200 1 CEST} + {-449708400 3600 0 CET} + {-428540400 7200 1 CEST} + {-418258800 3600 0 CET} + {-397090800 7200 1 CEST} {-386809200 3600 0 CET} - {323827200 7200 1 CEST} - {338950800 3600 0 CET} - {354675600 7200 1 CEST} - {370400400 3600 0 CET} - {386125200 7200 1 CEST} - {401850000 3600 0 CET} - {417574800 7200 1 CEST} - {433299600 3600 0 CET} + {323823600 7200 1 CEST} + {338943600 3600 0 CET} + {354668400 7200 1 CEST} + {370393200 3600 0 CET} + {386118000 7200 1 CEST} + {401842800 3600 0 CET} + {417567600 7200 1 CEST} + {433292400 3600 0 CET} + {441759600 3600 0 CET} {449024400 7200 1 CEST} {465354000 3600 0 CET} {481078800 7200 1 CEST} diff --git a/library/tzdata/Europe/Monaco b/library/tzdata/Europe/Monaco index f887b0b..7428b2f 100644 --- a/library/tzdata/Europe/Monaco +++ b/library/tzdata/Europe/Monaco @@ -2,8 +2,8 @@ set TZData(:Europe/Monaco) { {-9223372036854775808 1772 0 LMT} - {-2486680172 561 0 PMT} - {-1855958961 0 0 WET} + {-2448318572 561 0 PMT} + {-1854403761 0 0 WET} {-1689814800 3600 1 WEST} {-1680397200 0 0 WET} {-1665363600 3600 1 WEST} diff --git a/library/tzdata/Europe/Paris b/library/tzdata/Europe/Paris index 4b22a09..7208e55 100644 --- a/library/tzdata/Europe/Paris +++ b/library/tzdata/Europe/Paris @@ -2,8 +2,8 @@ set TZData(:Europe/Paris) { {-9223372036854775808 561 0 LMT} - {-2486678901 561 0 PMT} - {-1855958901 0 0 WET} + {-2486592561 561 0 PMT} + {-1855958961 0 0 WET} {-1689814800 3600 1 WEST} {-1680397200 0 0 WET} {-1665363600 3600 1 WEST} diff --git a/library/tzdata/Pacific/Fiji b/library/tzdata/Pacific/Fiji index e316b93..a062913 100644 --- a/library/tzdata/Pacific/Fiji +++ b/library/tzdata/Pacific/Fiji @@ -29,7 +29,7 @@ set TZData(:Pacific/Fiji) { {1547301600 43200 0 +12} {1573308000 46800 1 +12} {1578751200 43200 0 +12} - {1604757600 46800 1 +12} + {1608386400 46800 1 +12} {1610805600 43200 0 +12} {1636812000 46800 1 +12} {1642255200 43200 0 +12} diff --git a/macosx/GNUmakefile b/macosx/GNUmakefile index 9d82e42..93fd843 100644 --- a/macosx/GNUmakefile +++ b/macosx/GNUmakefile @@ -32,6 +32,18 @@ MANDIR ?= ${PREFIX}/man # set to non-empty value to install manpages in addition to html help: INSTALL_MANPAGES ?= +# Checks and overrides for subframework builds +ifeq (${SUBFRAMEWORK},1) +ifeq (${DYLIB_INSTALL_DIR},) + @echo "Cannot install subframework with empty DYLIB_INSTALL_DIR !" && false +endif +ifeq (${DESTDIR},) + @echo "Cannot install subframework with empty DESTDIR !" && false +endif +override BUILD_DIR = ${DESTDIR}/build +override INSTALL_PATH = /Frameworks +endif + #------------------------------------------------------------------------------------------------------- # meta targets @@ -76,7 +88,7 @@ space := ${empty} ${empty} objdir = $(subst ${space},\ ,${OBJ_DIR}) develop_make_args := BUILD_STYLE=Development CONFIGURE_ARGS=--enable-symbols -deploy_make_args := BUILD_STYLE=Deployment INSTALL_TARGET=install-strip \ +deploy_make_args := BUILD_STYLE=Deployment INSTALL_TARGET=install \ EXTRA_CFLAGS=-DNDEBUG embedded_make_args := EMBEDDED_BUILD=1 install_make_args := INSTALL_BUILD=1 diff --git a/macosx/README b/macosx/README index f28c055..3035bc8 100644 --- a/macosx/README +++ b/macosx/README @@ -165,3 +165,13 @@ If you only want to build and install the debug or optimized build, use the For example, to build and install only the optimized versions: make -C tcl${ver}/macosx deploy sudo make -C tcl${ver}/macosx install-deploy + +- To build a Tcl.framework for use as a subframework in another framework, use the +install-embedded target and set SUBFRAMEWORK=1. Set the DYLIB_INSTALL_DIR +variable to the path which should be the install_name path of the Tcl library, set +the DESTDIR variable to the pathname of a staging directory where the framework +will be written . For example, running this command in the Tcl source directory: + make -C macosx install-embedded SUBFRAMEWORK=1 DESTDIR=/tmp/tcl \ + DYLIB_INSTALL_DIR=/Library/Frameworks/Some.framework/Versions/X.Y/Frameworks/Tcl.framework +will produce a Tcl.framework intended for installing as a subframework of +Some.framework. The framework will be found in /tmp/tcl/Frameworks/ diff --git a/macosx/Tcl-Common.xcconfig b/macosx/Tcl-Common.xcconfig index 0670479..39301db 100644 --- a/macosx/Tcl-Common.xcconfig +++ b/macosx/Tcl-Common.xcconfig @@ -19,7 +19,7 @@ GCC_NO_COMMON_BLOCKS = YES GCC_DYNAMIC_NO_PIC = YES GCC_VERSION = 4.2 GCC = gcc-$(GCC_VERSION) -WARNING_CFLAGS = -Wall -Wwrite-strings -Wextra -Wdeclaration-after-statement -Wno-unused-parameter -Wno-missing-field-initializers -Wno-unused-value -Winit-self -Wpointer-arith -Wcast-align -Wdisabled-optimization -Winline $(WARNING_CFLAGS) +WARNING_CFLAGS = -Wall -Wextra -Wshadow -Wwrite-strings -Wpointer-arith -Wc++-compat -Wdeclaration-after-statement -Winit-self -Wcast-align -Wdisabled-optimization -Winline $(WARNING_CFLAGS) BINDIR = $(PREFIX)/bin CFLAGS = $(CFLAGS) CPPFLAGS = -mmacosx-version-min=$(MACOSX_DEPLOYMENT_TARGET) $(CPPFLAGS) diff --git a/macosx/Tcl.xcode/project.pbxproj b/macosx/Tcl.xcode/project.pbxproj index e9a12b9..d7d23fb 100644 --- a/macosx/Tcl.xcode/project.pbxproj +++ b/macosx/Tcl.xcode/project.pbxproj @@ -1904,7 +1904,7 @@ ); runOnlyForDeploymentPostprocessing = 0; shellPath = /bin/bash; - shellScript = "if [ \"${ACTION:-build}\" == \"build\" ]; then\nif [ -z \"${HOME}\" ]; then export HOME=\"$(echo ~)\"; fi\ncd \"${TARGET_TEMP_DIR}\"; rm -rf \"${DERIVED_FILE_DIR}\"; mkdir -p \"${DERIVED_FILE_DIR}\"\nprintf '%s%s%s%s%s' '\npackage require tcltest 2.2\nnamespace import tcltest::*\nconfigure -testdir [file normalize {' \"${TCL_SRCROOT}\" '/tests}]\nconfigure -tmpdir [file normalize {' \"${DERIVED_FILE_DIR}\" '}]\nconfigure -verbose [concat [configure -verbose] line]\nrunAllTests\n' | \"${TEST_RIG}\"; TEST_RIG_RESULT=$?\n[ ${TEST_RIG_RESULT} -ne 0 ] && echo \"tcltest:0: error: tcltest exited abnormally with code ${TEST_RIG_RESULT}.\"\nexit ${TEST_RIG_RESULT}\nfi"; + shellScript = "if [ \"${ACTION:-build}\" == \"build\" ]; then\nif [ -z \"${HOME}\" ]; then export HOME=\"$(echo ~)\"; fi\ncd \"${TARGET_TEMP_DIR}\"; rm -rf \"${DERIVED_FILE_DIR}\"; mkdir -p \"${DERIVED_FILE_DIR}\"\nprintf '%s%s%s%s%s' '\npackage require tcltest 2.5\nnamespace import tcltest::*\nconfigure -testdir [file normalize {' \"${TCL_SRCROOT}\" '/tests}]\nconfigure -tmpdir [file normalize {' \"${DERIVED_FILE_DIR}\" '}]\nconfigure -verbose [concat [configure -verbose] line]\nrunAllTests\n' | \"${TEST_RIG}\"; TEST_RIG_RESULT=$?\n[ ${TEST_RIG_RESULT} -ne 0 ] && echo \"tcltest:0: error: tcltest exited abnormally with code ${TEST_RIG_RESULT}.\"\nexit ${TEST_RIG_RESULT}\nfi"; showEnvVarsInLog = 0; }; F97AF02F0B665DA900310EA2 /* Build Tcl */ = { diff --git a/macosx/Tcl.xcodeproj/project.pbxproj b/macosx/Tcl.xcodeproj/project.pbxproj index e72bfe3..1d200a0 100644 --- a/macosx/Tcl.xcodeproj/project.pbxproj +++ b/macosx/Tcl.xcodeproj/project.pbxproj @@ -1904,7 +1904,7 @@ ); runOnlyForDeploymentPostprocessing = 0; shellPath = /bin/bash; - shellScript = "if [ \"${ACTION:-build}\" == \"build\" ]; then\nif [ -z \"${HOME}\" ]; then export HOME=\"$(echo ~)\"; fi\ncd \"${TARGET_TEMP_DIR}\"; rm -rf \"${DERIVED_FILE_DIR}\"; mkdir -p \"${DERIVED_FILE_DIR}\"\nprintf '%s%s%s%s%s' '\npackage require tcltest 2.2\nnamespace import tcltest::*\nconfigure -testdir [file normalize {' \"${TCL_SRCROOT}\" '/tests}]\nconfigure -tmpdir [file normalize {' \"${DERIVED_FILE_DIR}\" '}]\nconfigure -verbose [concat [configure -verbose] line]\nrunAllTests\n' | \"${TEST_RIG}\"; TEST_RIG_RESULT=$?\n[ ${TEST_RIG_RESULT} -ne 0 ] && echo \"tcltest:0: error: tcltest exited abnormally with code ${TEST_RIG_RESULT}.\"\nexit ${TEST_RIG_RESULT}\nfi"; + shellScript = "if [ \"${ACTION:-build}\" == \"build\" ]; then\nif [ -z \"${HOME}\" ]; then export HOME=\"$(echo ~)\"; fi\ncd \"${TARGET_TEMP_DIR}\"; rm -rf \"${DERIVED_FILE_DIR}\"; mkdir -p \"${DERIVED_FILE_DIR}\"\nprintf '%s%s%s%s%s' '\npackage require tcltest 2.5\nnamespace import tcltest::*\nconfigure -testdir [file normalize {' \"${TCL_SRCROOT}\" '/tests}]\nconfigure -tmpdir [file normalize {' \"${DERIVED_FILE_DIR}\" '}]\nconfigure -verbose [concat [configure -verbose] line]\nrunAllTests\n' | \"${TEST_RIG}\"; TEST_RIG_RESULT=$?\n[ ${TEST_RIG_RESULT} -ne 0 ] && echo \"tcltest:0: error: tcltest exited abnormally with code ${TEST_RIG_RESULT}.\"\nexit ${TEST_RIG_RESULT}\nfi"; showEnvVarsInLog = 0; }; F97AF02F0B665DA900310EA2 /* Build Tcl */ = { diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index 06ad180..52c43e7 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -192,11 +192,11 @@ TclMacOSXGetFileAttribute( OSSwapBigToHostInt32(finder->type)); break; case MACOSX_HIDDEN_ATTRIBUTE: - *attributePtrPtr = Tcl_NewWideIntObj( + TclNewIntObj(*attributePtrPtr, (finder->fdFlags & kFinfoIsInvisible) != 0); break; case MACOSX_RSRCLENGTH_ATTRIBUTE: - *attributePtrPtr = Tcl_NewWideIntObj(*rsrcForkSize); + TclNewIntObj(*attributePtrPtr, *rsrcForkSize); break; } return TCL_OK; diff --git a/pkgs/README b/pkgs/README index 159a237..4633e0b 100644 --- a/pkgs/README +++ b/pkgs/README @@ -17,7 +17,7 @@ needs to conform to the following conventions. "configure". When the program "configure" is run, it should generate a file "Makefile" in the current working directory. The "configure" program should be able to accept as command line arguments all the - arguments that can be passed to the master unix/configure program. It + arguments that can be passed to the top unix/configure program. It should also accept the --with-tcl= and --with-tclinclude= options in the conventional way. diff --git a/tests/aaa_exit.test b/tests/aaa_exit.test index a8aa6fc..d4d2a7c 100644 --- a/tests/aaa_exit.test +++ b/tests/aaa_exit.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/all.tcl b/tests/all.tcl index 52c8763..c72334a 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -1,7 +1,7 @@ # all.tcl -- # # This file contains a top-level script to run all of the Tcl -# tests. Execute it by invoking "source all.test" when running tcltest +# tests. Execute it by invoking "source all.tcl" when running tcltest # in this directory. # # Copyright (c) 1998-1999 by Scriptics Corporation. diff --git a/tests/append.test b/tests/append.test index 0487f5c..ef4a194 100644 --- a/tests/append.test +++ b/tests/append.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } unset -nocomplain x diff --git a/tests/appendComp.test b/tests/appendComp.test index ebd48eb..66941a9 100644 --- a/tests/appendComp.test +++ b/tests/appendComp.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } catch {unset x} @@ -359,9 +359,9 @@ test appendComp-7.9 {append var does not trigger read trace} -setup { } -result {0} test appendComp-8.1 {defer error to runtime} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { proc foo {} { proc append args {} append @@ -369,7 +369,7 @@ test appendComp-8.1 {defer error to runtime} -setup { foo } } -cleanup { - interp delete slave + interp delete child } -result {} # New tests for bug 3057639 to show off the more consistent behaviour of diff --git a/tests/apply.test b/tests/apply.test index 88f63fd..227d3c1 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -13,7 +13,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/assocd.test b/tests/assocd.test index edf55c4..7d89daa 100644 --- a/tests/assocd.test +++ b/tests/assocd.test @@ -11,8 +11,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/async.test b/tests/async.test index ac3c08c..ad058a0 100644 --- a/tests/async.test +++ b/tests/async.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/auto-files.zip b/tests/auto-files.zip Binary files differnew file mode 100644 index 0000000..b8bdf88 --- /dev/null +++ b/tests/auto-files.zip diff --git a/tests/auto0/auto1/file1.tcl b/tests/auto0/auto1/file1.tcl new file mode 100644 index 0000000..bd8b92b --- /dev/null +++ b/tests/auto0/auto1/file1.tcl @@ -0,0 +1,3 @@ +proc report1 {args} { + return ok1 +} diff --git a/tests/auto0/auto1/package1.tcl b/tests/auto0/auto1/package1.tcl new file mode 100644 index 0000000..32d7c56 --- /dev/null +++ b/tests/auto0/auto1/package1.tcl @@ -0,0 +1,5 @@ +proc HeresPackage1 {args} { + return OK1 +} + +package provide SafeTestPackage1 1.2.3 diff --git a/tests/auto0/auto1/pkgIndex.tcl b/tests/auto0/auto1/pkgIndex.tcl new file mode 100644 index 0000000..babb6d5 --- /dev/null +++ b/tests/auto0/auto1/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded SafeTestPackage1 1.2.3 [list source [file join $dir package1.tcl]] diff --git a/tests/auto0/auto1/tclIndex b/tests/auto0/auto1/tclIndex new file mode 100644 index 0000000..bbfa6d4 --- /dev/null +++ b/tests/auto0/auto1/tclIndex @@ -0,0 +1,9 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(report1) [list source [file join $dir file1.tcl]] diff --git a/tests/auto0/auto2/file2.tcl b/tests/auto0/auto2/file2.tcl new file mode 100644 index 0000000..5bc622f --- /dev/null +++ b/tests/auto0/auto2/file2.tcl @@ -0,0 +1,3 @@ +proc report2 {args} { + return ok2 +} diff --git a/tests/auto0/auto2/package2.tcl b/tests/auto0/auto2/package2.tcl new file mode 100644 index 0000000..61774df --- /dev/null +++ b/tests/auto0/auto2/package2.tcl @@ -0,0 +1,5 @@ +proc HeresPackage2 {args} { + return OK2 +} + +package provide SafeTestPackage2 2.3.4 diff --git a/tests/auto0/auto2/pkgIndex.tcl b/tests/auto0/auto2/pkgIndex.tcl new file mode 100644 index 0000000..1022691 --- /dev/null +++ b/tests/auto0/auto2/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded SafeTestPackage2 2.3.4 [list source [file join $dir package2.tcl]] diff --git a/tests/auto0/auto2/tclIndex b/tests/auto0/auto2/tclIndex new file mode 100644 index 0000000..9cd2a74 --- /dev/null +++ b/tests/auto0/auto2/tclIndex @@ -0,0 +1,9 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(report2) [list source [file join $dir file2.tcl]] diff --git a/tests/auto0/modules/mod1/test1-1.0.tm b/tests/auto0/modules/mod1/test1-1.0.tm new file mode 100644 index 0000000..927fa6f --- /dev/null +++ b/tests/auto0/modules/mod1/test1-1.0.tm @@ -0,0 +1,5 @@ +namespace eval mod1::test1 {} + +proc mod1::test1::try1 args { + return res1 +} diff --git a/tests/auto0/modules/mod2/test2-2.0.tm b/tests/auto0/modules/mod2/test2-2.0.tm new file mode 100644 index 0000000..b5cd45b --- /dev/null +++ b/tests/auto0/modules/mod2/test2-2.0.tm @@ -0,0 +1,5 @@ +namespace eval mod2::test2 {} + +proc mod2::test2::try2 args { + return res2 +} diff --git a/tests/auto0/modules/test0-0.5.tm b/tests/auto0/modules/test0-0.5.tm new file mode 100644 index 0000000..19f3613 --- /dev/null +++ b/tests/auto0/modules/test0-0.5.tm @@ -0,0 +1,5 @@ +namespace eval test0 {} + +proc test0::try0 args { + return res0 +} diff --git a/tests/autoMkindex.test b/tests/autoMkindex.test index 85f7c0b..8662888 100644 --- a/tests/autoMkindex.test +++ b/tests/autoMkindex.test @@ -10,7 +10,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -146,10 +146,10 @@ test autoMkindex-1.3 {examine tclIndex} -setup { test autoMkindex-2.1 {commands on the autoload path can be imported} -setup { file delete tclIndex - interp create slave + interp create child } -body { auto_mkindex . autoMkindex.tcl - slave eval { + child eval { namespace eval blt {} set auto_path [linsert $auto_path 0 .] set info [list [catch {namespace import buried::*} result] $result] @@ -159,7 +159,7 @@ test autoMkindex-2.1 {commands on the autoload path can be imported} -setup { return $info } } -cleanup { - interp delete slave + interp delete child } -result "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two" # Test auto_mkindex hooks @@ -335,14 +335,14 @@ test autoMkindex-5.2 {correctly locate auto loaded procs with []} -setup { proc {[magic mojo proc]} {} {} } [file join pkg magicchar2.tcl] set result {} - interp create slave + interp create child } -body { auto_mkindex . pkg/magicchar2.tcl - # Make a slave interp to test the autoloading - slave eval {lappend auto_path [pwd]} - slave eval {catch {{[magic mojo proc]}}} + # Make a child interp to test the autoloading + child eval {lappend auto_path [pwd]} + child eval {catch {{[magic mojo proc]}}} } -cleanup { - interp delete slave + interp delete child removeFile [file join pkg magicchar2.tcl] removeDirectory pkg } -result 0 diff --git a/tests/basic.test b/tests/basic.test index 428fd93..38ea11e 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -15,8 +15,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -999,13 +1001,13 @@ test basic-49.2 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex { } {global} test basic-50.1 {[586e71dce4] EvalObjv level #0 exception handling} -setup { - interp create slave - interp alias {} foo slave return + interp create child + interp alias {} foo child return } -body { list [catch foo m] $m } -cleanup { unset -nocomplain m - interp delete slave + interp delete child } -result {0 {}} # Clean up after expand tests diff --git a/tests/binary.test b/tests/binary.test index b2a2a40..cf3195f 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -11,7 +11,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}] diff --git a/tests/case.test b/tests/case.test index 0aba5cd..87cb2c8 100644 --- a/tests/case.test +++ b/tests/case.test @@ -17,7 +17,7 @@ if {![llength [info commands case]]} { } if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/chan.test b/tests/chan.test index 7d32a8f..5d05935 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -8,7 +8,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -173,7 +173,7 @@ test chan-16.9 {chan command: pending input subcommand} -setup { lappend ::chan-16.9-data $r $l $e $b $i - if {$r != -1 || $e || $l || !$b || $i > 128} { + if {$r >= 0 || $e || $l || !$b || $i > 128} { set data [read $sock $i] lappend ::chan-16.9-data [string range $data 0 2] lappend ::chan-16.9-data [string range $data end-2 end] diff --git a/tests/chanio.test b/tests/chanio.test index 46a0c06..daacdd0 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -14,11 +14,16 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 + namespace import -force ::tcltest::* } namespace eval ::tcl::test::io { - namespace import ::tcltest::* + + if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* + } variable umaskValue variable path @@ -43,6 +48,7 @@ namespace eval ::tcl::test::io { testConstraint testmainthread [llength [info commands testmainthread]] testConstraint testservicemode [llength [info commands testservicemode]] testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}] + testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] # You need a *very* special environment to do some tests. In particular, # many file systems do not support large-files... @@ -5720,7 +5726,7 @@ test chan-io-45.3 {DeleteFileEvent, cleanup on chan close} {fileevent} { # Execute these tests only if the "testfevent" command is present. -test chan-io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} { +test chan-io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent notOSX} { testfevent create set script "set f \[[list open $path(foo) r]]\n" append script { @@ -6379,12 +6385,16 @@ test chan-io-50.1 {testing handler deletion} -setup { set f [open $path(test1) w] chan close $f set f [open $path(test1) r] + variable z not_called + set timer [after 50 lappend z timeout] + testservicemode 0 testchannelevent $f add readable [namespace code { variable z called testchannelevent $f delete 0 }] - variable z not_called - update + testservicemode 1 + vwait z + after cancel $timer set z } -cleanup { chan close $f @@ -6474,7 +6484,7 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { set f [open $path(test1) w] chan close $f update -} -constraints {testchannelevent testservicemode} -body { +} -constraints {testchannelevent testservicemode notOSX} -body { proc notcalled {f} { variable z lappend z "notcalled was called!! $f" diff --git a/tests/clock.test b/tests/clock.test index 9052990..c51c829 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 992a8f4..8f01816 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -11,7 +11,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -30,6 +30,7 @@ testConstraint linkDirectory [expr { ($::tcl_platform(osVersion) >= 5.0 && [lindex [file system [temporaryDirectory]] 1] eq "NTFS") }] +testConstraint notWine [expr {$::tcl_platform(platform) ne "windows" || ![info exists ::env(TRAVIS_OS_NAME)] || ![string match linux $::env(TRAVIS_OS_NAME)]}] global env set cmdAHwd [pwd] @@ -261,7 +262,7 @@ test cmdAH-6.3 {Tcl_FileObjCmd: volumes} -constraints unix -body { test cmdAH-6.4 {Tcl_FileObjCmd: volumes} -constraints win -body { set volumeList [string tolower [file volumes]] set element [lsearch -exact $volumeList "c:/"] - list [expr {$element>-1}] [glob -nocomplain [lindex $volumeList $element]*] + list [expr {$element>=0}] [glob -nocomplain [lindex $volumeList $element]*] } -match glob -result {1 *} # attributes @@ -1348,7 +1349,7 @@ test cmdAH-25.2.1 {Tcl_FileObjCmd: owned} -constraints unix -setup { test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unix notRoot} { file owned / } 0 -test cmdAH-25.3.1 {Tcl_FileObjCmd: owned} -constraints win -body { +test cmdAH-25.3.1 {Tcl_FileObjCmd: owned} -constraints {win notWine} -body { if {[info exists env(SystemRoot)]} { file owned $env(SystemRoot) } else { @@ -1538,7 +1539,7 @@ test cmdAH-29.4 {Tcl_FileObjCmd: type} -constraints {unix} -setup { } -cleanup { file delete $linkfile } -result link -test cmdAH-29.4.1 {Tcl_FileObjCmd: type} -constraints {linkDirectory} -setup { +test cmdAH-29.4.1 {Tcl_FileObjCmd: type} -constraints {linkDirectory notWine} -setup { set tempdir [makeDirectory temp] } -body { set linkdir [file join [temporaryDirectory] link.dir] @@ -1638,7 +1639,7 @@ test cmdAH-31.9 {Tcl_FileObjCmd: channels in other interp} { lsort [safeInterp eval [list file channels]] } [lsort [list stdout $newFileId]] test cmdAH-31.10 {Tcl_FileObjCmd: channels in other interp} { - # we can now write to $newFileId from slave + # we can now write to $newFileId from child safeInterp eval [list puts $newFileId "hello"] } {} interp transfer {} $newFileId safeInterp diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 57607bd..68f7892 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -9,10 +9,11 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } + ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test index 0a587e8..e690002 100644 --- a/tests/cmdInfo.test +++ b/tests/cmdInfo.test @@ -13,8 +13,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 43b3703..0675a5d 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -11,9 +11,9 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2.1}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.1 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } namespace eval ::tcl::test::cmdMZ { diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index 237aab4..f573cfa 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -13,10 +13,11 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } + ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/compExpr.test b/tests/compExpr.test index 8803f17..0be2126 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -9,7 +9,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -341,9 +341,9 @@ test compExpr-7.1 {Memory Leak} -constraints memory -setup { } -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { - interp create slave - slave eval expr 1+2+3+4+5+6+7+8+9+10+11+12+13 - interp delete slave + interp create child + child eval expr 1+2+3+4+5+6+7+8+9+10+11+12+13 + interp delete child set tmp $end set end [getbytes] } diff --git a/tests/compile.test b/tests/compile.test index 18e978f..b90f124 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -11,8 +11,11 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/concat.test b/tests/concat.test index eeb11ca..8ff5500 100644 --- a/tests/concat.test +++ b/tests/concat.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/config.test b/tests/config.test index 1767f59..b78e29d 100644 --- a/tests/config.test +++ b/tests/config.test @@ -13,7 +13,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/coroutine.test b/tests/coroutine.test index 9546492..6d79fd7 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -10,7 +10,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -771,25 +771,25 @@ test coroutine-8.0.1 {coro inject after error} -body { lappend ::result [catch {demo} err] $err } -result {inject-executed 1 test} test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body { - interp create slave - slave eval { + interp create child + child eval { coroutine demo apply {{} { while {1} yield }} demo tcl::unsupported::inject demo set ::result inject-executed } - interp delete slave + interp delete child } -result {} test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body { - interp create slave - slave eval { + interp create child + child eval { coroutine demo apply {{} { while {1} yield }} demo tcl::unsupported::inject demo set ::result inject-executed } - slave eval demo - set result [slave eval {set ::result}] + child eval demo + set result [child eval {set ::result}] - interp delete slave + interp delete child set result } -result {inject-executed} diff --git a/tests/dcall.test b/tests/dcall.test index 41dd777..7d86135 100644 --- a/tests/dcall.test +++ b/tests/dcall.test @@ -11,8 +11,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/dstring.test b/tests/dstring.test index 5feb355..8a24ebe 100644 --- a/tests/dstring.test +++ b/tests/dstring.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/encoding.test b/tests/encoding.test index f483160..d0ca114 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -8,13 +8,15 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + namespace eval ::tcl::test::encoding { variable x -namespace import -force ::tcltest::* - catch { ::tcltest::loadTestedCommands package require -exact Tcltest [info patchlevel] diff --git a/tests/env.test b/tests/env.test index 774617c..c901148 100644 --- a/tests/env.test +++ b/tests/env.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -104,7 +104,9 @@ variable keep { SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING __CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM - CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432 + CommonProgramFiles CommonProgramFiles(x86) ProgramFiles + ProgramFiles(x86) CommonProgramW6432 ProgramW6432 + WINECONFIGDIR WINEDATADIR WINEDLLDIR0 WINEHOMEDIR } variable printenvScript [makeFile [string map [list @keep@ [list $keep]] { @@ -326,11 +328,11 @@ test env-5.2 {corner cases - unset the env array} -setup { } -result {0} -test env-5.3 {corner cases: unset the env in master should unset child} -setup { +test env-5.3 {corner cases: unset the env in parent should unset child} -setup { setup1 interp create i } -body { - # Variables deleted in a master interp should be deleted in child interp + # Variables deleted in a parent interp should be deleted in child interp # too. i eval {set env(THIS_SHOULD_EXIST) a} set result [set env(THIS_SHOULD_EXIST)] diff --git a/tests/error.test b/tests/error.test index 28e4f5c..a111c80 100644 --- a/tests/error.test +++ b/tests/error.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/eval.test b/tests/eval.test index 70ceac8..d473fdf 100644 --- a/tests/eval.test +++ b/tests/eval.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/event.test b/tests/event.test index 70d4cff..3194547 100644 --- a/tests/event.test +++ b/tests/event.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +package require tcltest 2.5 namespace import -force ::tcltest::* catch { diff --git a/tests/exec.test b/tests/exec.test index 36aeae5..5082393 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -14,8 +14,10 @@ # There is no point in running Valgrind on cases where [exec] forks but then # fails and the child process doesn't go through full cleanup. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/execute.test b/tests/execute.test index fbc4f99..6d27e55 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -15,7 +15,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -657,56 +657,56 @@ test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} -se namespace delete foo } -result {0 AHA!} test execute-6.9 {TclCompEvalObj: bytecode interp validation} -setup { - interp create slave + interp create child } -body { set script { llength {} } - slave eval {proc llength args {return AHA!}} + child eval {proc llength args {return AHA!}} set result {} lappend result [if 1 $script] - lappend result [slave eval $script] + lappend result [child eval $script] } -cleanup { - interp delete slave + interp delete child } -result {0 AHA!} test execute-6.10 {TclCompEvalObj: bytecode interp validation} -body { set script { llength {} } - interp create slave + interp create child set result {} - lappend result [slave eval $script] - interp delete slave - interp create slave - lappend result [slave eval $script] + lappend result [child eval $script] + interp delete child + interp create child + lappend result [child eval $script] } -cleanup { - catch {interp delete slave} + catch {interp delete child} } -result {0 0} test execute-6.11 {Tcl_ExprObj: exprcode interp validation} -setup { - interp create slave + interp create child } -constraints testexprlongobj -body { set e { [llength {}]+1 } set result {} - load {} Tcltest slave - interp alias {} e slave testexprlongobj + load {} Tcltest child + interp alias {} e child testexprlongobj lappend result [e $e] - interp delete slave - interp create slave - load {} Tcltest slave - interp alias {} e slave testexprlongobj + interp delete child + interp create child + load {} Tcltest child + interp alias {} e child testexprlongobj lappend result [e $e] } -cleanup { - interp delete slave + interp delete child } -result {{This is a result: 1} {This is a result: 1}} test execute-6.12 {Tcl_ExprObj: exprcode interp validation} -setup { - interp create slave + interp create child } -body { set e { [llength {}]+1 } set result {} - interp alias {} e slave expr + interp alias {} e child expr lappend result [e $e] - interp delete slave - interp create slave - interp alias {} e slave expr + interp delete child + interp create child + interp alias {} e child expr lappend result [e $e] } -cleanup { - interp delete slave + interp delete child } -result {1 1} test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} -body { set e { [llength {}]+1 } @@ -747,16 +747,16 @@ test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} -setu namespace delete foo } -result {1 2} test execute-6.16 {Tcl_ExprObj: exprcode interp validation} -setup { - interp create slave + interp create child } -body { set e { [llength {}]+1 } - interp alias {} e slave expr - slave eval {proc llength args {return 1}} + interp alias {} e child expr + child eval {proc llength args {return 1}} set result {} lappend result [expr $e] lappend result [e $e] } -cleanup { - interp delete slave + interp delete child } -result {1 2} test execute-6.17 {Tcl_ExprObj: exprcode context validation} -body { proc foo e {set v 0; expr $e} @@ -982,9 +982,9 @@ test execute-8.5 {Bug 2038069} -setup { "catch \[list error FOO\] m o"} -errorline 2} test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup { - interp create slave - slave eval { - package require tcltest + interp create child + child eval { + package require tcltest 2.5 catch [list package require -exact Tcltest [info patchlevel]] ::tcltest::loadTestedCommands if {[namespace which -command testbumpinterpepoch] eq ""} { @@ -992,32 +992,32 @@ test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup } } } -body { - slave eval { + child eval { lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C; } - slave eval { + child eval { set i 0; while {[incr i] < 3} { lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C; } } - slave eval { + child eval { set i 0; while {[incr i] < 3} { lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C; } } - slave eval { + child eval { catch { lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C; } } - slave eval {set res} + child eval {set res} } -cleanup { - interp delete slave + interp delete child } -result [lrepeat 4 A B] test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), exception case} -setup { - interp create slave - slave eval { - package require tcltest + interp create child + child eval { + package require tcltest 2.5 catch [list package require -exact Tcltest [info patchlevel]] ::tcltest::loadTestedCommands if {[namespace which -command testbumpinterpepoch] eq ""} { @@ -1027,28 +1027,28 @@ test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), excepti } -body { set res {} lappend res [catch { - slave eval { + child eval { lappend res A; testbumpinterpepoch; lappend res B; return -code error test; lappend res C; } } e] $e lappend res [catch { - slave eval { + child eval { lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C; } } e] $e lappend res [catch { - slave eval { + child eval { lappend res A; testbumpinterpepoch; lappend res B; return -code return test; lappend res C; } } e] $e lappend res [catch { - slave eval { + child eval { lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C; } } e] $e - list $res [slave eval {set res}] + list $res [child eval {set res}] } -cleanup { - interp delete slave + interp delete child } -result [list {1 test 1 test 2 test 3 {}} [lrepeat 4 A B]] test execute-9.1 {Interp result resetting [Bug 1522803]} { @@ -1069,16 +1069,16 @@ test execute-10.1 {TclExecuteByteCode, INST_CONCAT1, bytearrays} { apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} \u0130 } {48 {304 304}} test execute-10.2 {Bug 2802881} -setup { - interp create slave + interp create child } -body { # If [Bug 2802881] is not fixed, this will segfault - slave eval { + child eval { trace add variable ::errorInfo write {expr {$foo} ;#} proc demo {} {a {}{}} demo } } -cleanup { - interp delete slave + interp delete child } -returnCodes error -match glob -result * test execute-10.3 {Bug 3072640} -setup { proc generate {n} { @@ -1103,9 +1103,9 @@ test execute-10.3 {Bug 3072640} -setup { } -result 4 test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { set x [lrepeat 1320 199] for {set i 0} {$i < 20} {incr i} { lappend x $i @@ -1115,7 +1115,7 @@ test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup { return ok } } -cleanup { - interp delete slave + interp delete child } -result ok test execute-11.2 {Bug 268b23df11} -setup { diff --git a/tests/expr-old.test b/tests/expr-old.test index de10da0..ff63b12 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -13,8 +13,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2.1 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/expr.test b/tests/expr.test index 4e8706f..507fb74 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -11,7 +11,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/fCmd.test b/tests/fCmd.test index e8ed6f9..a1e0a6e 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -11,7 +11,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -41,6 +41,7 @@ if {[testConstraint win]} { testConstraint reg 1 } } +testConstraint notWine [expr {$::tcl_platform(platform) ne "windows" || ![info exists ::env(TRAVIS_OS_NAME)] || ![string match linux $::env(TRAVIS_OS_NAME)]}] set tmpspace /tmp;# default value # Find a group that exists on this Unix system, or else skip tests that @@ -416,7 +417,7 @@ test fCmd-5.4 {TclFileDeleteCmd: multiple files} -constraints notRoot -setup { } -cleanup {cleanup} -result {1 1 1 0 0 0} test fCmd-5.5 {TclFileDeleteCmd: stop at first error} -setup { cleanup -} -constraints {notRoot unixOrWin} -body { +} -constraints {notRoot unixOrWin notWine} -body { createfile tf1 createfile tf2 file mkdir td1 @@ -563,7 +564,7 @@ test fCmd-6.15 {CopyRenameOneFile: TclpRenameFile succeeds} -setup { } -result 1 test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} -setup { cleanup -} -constraints {notRoot} -body { +} -constraints {notRoot notWine} -body { file mkdir [file join td1 td2] createfile [file join td1 td2 tf1] file mkdir td2 @@ -572,12 +573,12 @@ test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} -setup { [subst {error renaming "td2" to "[file join td1 td2]": file *}] test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} -setup { cleanup -} -constraints {notRoot} -returnCodes error -body { +} -constraints {notRoot notWine} -returnCodes error -body { file rename -force $root tf1 } -result [subst {error renaming "$root" to "tf1": trying to rename a volume or move a directory into itself}] test fCmd-6.18 {CopyRenameOneFile: errno != EXDEV} -setup { cleanup -} -constraints {notRoot} -body { +} -constraints {notRoot notWine} -body { file mkdir [file join td1 td2] createfile [file join td1 td2 tf1] file mkdir td2 @@ -811,7 +812,7 @@ test fCmd-9.4.b {file rename: comprehensive: dir to new name} -setup { } -result {{td3 td4} 1 0} test fCmd-9.5 {file rename: comprehensive: file to self} -setup { cleanup -} -constraints {notRoot testchmod} -body { +} -constraints {notRoot testchmod notWine} -body { createfile tf1 tf1 createfile tf2 tf2 testchmod 0o444 tf2 @@ -841,7 +842,7 @@ test fCmd-9.6.b {file rename: comprehensive: dir to self} -setup { } -result {{td1 td2} 1 0} test fCmd-9.7 {file rename: comprehensive: file to existing file} -setup { cleanup -} -constraints {notRoot testchmod} -body { +} -constraints {notRoot testchmod notWine} -body { createfile tf1 createfile tf2 createfile tfs1 @@ -902,7 +903,7 @@ test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup { # Test can hit EEXIST or EBUSY, depending on underlying filesystem test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} -setup { cleanup -} -constraints {notRoot testchmod} -body { +} -constraints {notRoot testchmod notWine} -body { file mkdir tds1 file mkdir tds2 file mkdir [file join tdd1 tds1 xxx] @@ -966,14 +967,14 @@ test fCmd-9.12 {file rename: comprehensive: target exists} -setup { # Test can hit EEXIST or EBUSY, depending on underlying filesystem test fCmd-9.13 {file rename: comprehensive: can't overwrite target} -setup { cleanup -} -constraints {notRoot} -body { +} -constraints {notRoot notWine} -body { file mkdir [file join td1 td2] [file join td2 td1 td4] file rename -force td1 td2 } -returnCodes error -match glob -result \ [subst {error renaming "td1" to "[file join td2 td1]": file *}] test fCmd-9.14 {file rename: comprehensive: dir into self} -setup { cleanup -} -constraints {notRoot} -body { +} -constraints {notRoot notWine} -body { file mkdir td1 list [glob td*] [list [catch {file rename td1 td1} msg] $msg] } -result [subst {td1 {1 {error renaming "td1" to "[file join td1 td1]": trying to rename a volume or move a directory into itself}}}] @@ -1068,7 +1069,7 @@ test fCmd-10.3.1 {file copy: comprehensive: dir to new name} -setup { } -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 1] test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup { cleanup -} -constraints {notRoot testchmod} -body { +} -constraints {notRoot testchmod notWine} -body { createfile tf1 createfile tf2 createfile tfs1 @@ -2401,7 +2402,7 @@ test fCmd-28.10.1 {file link: linking to nonexistent path} -setup { test fCmd-28.11 {file link: success with directory} -setup { cd [temporaryDirectory] file delete -force abc.link -} -constraints {linkDirectory} -body { +} -constraints {linkDirectory notWine} -body { file link abc.link abc.dir } -cleanup { cd [workingDirectory] @@ -2409,7 +2410,7 @@ test fCmd-28.11 {file link: success with directory} -setup { test fCmd-28.12 {file link: cd into a link} -setup { cd [temporaryDirectory] file delete -force abc.link -} -constraints {linkDirectory} -body { +} -constraints {linkDirectory notWine} -body { file link abc.link abc.dir set orig [pwd] cd abc.link @@ -2435,7 +2436,7 @@ test fCmd-28.12 {file link: cd into a link} -setup { file delete -force abc.link cd [workingDirectory] } -result ok -test fCmd-28.13 {file link} -constraints {linkDirectory} -setup { +test fCmd-28.13 {file link} -constraints {linkDirectory notWine} -setup { cd [temporaryDirectory] file link abc.link abc.dir } -body { @@ -2469,7 +2470,7 @@ test fCmd-28.15.1 {file link: copies link not dir} -setup { test fCmd-28.15.2 {file link: copies link not dir} -setup { cd [temporaryDirectory] file delete -force abc.link -} -constraints {linkDirectory} -body { +} -constraints {linkDirectory notWine} -body { file link abc.link abc.dir file copy abc.link abc2.link list [file type abc2.link] [file tail [file link abc2.link]] @@ -2490,7 +2491,7 @@ cd [workingDirectory] test fCmd-28.16 {file link: glob inside link} -setup { cd [temporaryDirectory] file delete -force abc.link -} -constraints {linkDirectory} -body { +} -constraints {linkDirectory notWine} -body { file link abc.link abc.dir lsort [glob -dir abc.link -tails *] } -cleanup { @@ -2500,13 +2501,13 @@ test fCmd-28.16 {file link: glob inside link} -setup { test fCmd-28.17 {file link: glob -type l} -setup { cd [temporaryDirectory] file link abc.link abc.dir -} -constraints {linkDirectory} -body { +} -constraints {linkDirectory notWine} -body { glob -dir [pwd] -type l -tails abc* } -cleanup { file delete -force abc.link cd [workingDirectory] } -result {abc.link} -test fCmd-28.18 {file link: glob -type d} -constraints linkDirectory -setup { +test fCmd-28.18 {file link: glob -type d} -constraints {linkDirectory notWine} -setup { cd [temporaryDirectory] file link abc.link abc.dir } -body { @@ -2517,7 +2518,7 @@ test fCmd-28.18 {file link: glob -type d} -constraints linkDirectory -setup { } -result [lsort [list abc.link abc.dir abc2.dir]] test fCmd-28.19 {file link: relative paths} -setup { cd [temporaryDirectory] -} -constraints {win linkDirectory} -body { +} -constraints {win linkDirectory notWine} -body { file mkdir d1/d2/d3 file link d1/l2 d1/d2 } -cleanup { @@ -2575,12 +2576,12 @@ test fCmd-30.1 {file writable on 'My Documents'} -setup { } -constraints {win reg} -body { file writable $mydocsname } -result 1 -test fCmd-30.2 {file readable on 'NTUSER.DAT'} -constraints {win} -body { +test fCmd-30.2 {file readable on 'NTUSER.DAT'} -constraints {win notWine} -body { expr {[info exists env(USERPROFILE)] && [file exists $env(USERPROFILE)/NTUSER.DAT] && [file readable $env(USERPROFILE)/NTUSER.DAT]} } -result {1} -test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win} -body { +test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win notWine} -body { set r {} if {[info exists env(SystemDrive)]} { set path $env(SystemDrive)/pagefile.sys diff --git a/tests/fileName.test b/tests/fileName.test index 0e4cb9e..ac93383 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -11,10 +11,11 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } + ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -30,6 +31,7 @@ if {[testConstraint win]} { testConstraint symbolicLinkFile 0 testConstraint sharedCdrive [expr {![catch {cd //[info hostname]/c}]}] } +testConstraint notWine [expr {$::tcl_platform(platform) ne "windows" || ![info exists ::env(TRAVIS_OS_NAME)] || ![string match linux $::env(TRAVIS_OS_NAME)]}] # This match compares the first two words of the result. If the wanted result # is "equal", then this is successful if the words are equal. If the wanted # result is "not equal", then this is successful if the words are different. @@ -788,7 +790,7 @@ test filename-11.17 {Tcl_GlobCmd} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.17.1 {Tcl_GlobCmd} {win} { +test filename-11.17.1 {Tcl_GlobCmd} {win notWine} { lsort [glob -directory $globname *] } [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname .1]\ @@ -799,7 +801,7 @@ test filename-11.17.1 {Tcl_GlobCmd} {win} { [file join $globname y1.c] [file join $globname z1.c]]] test filename-11.17.2 {Tcl_GlobCmd} -setup { set dir [pwd] -} -constraints {notRoot linkDirectory} -body { +} -constraints {notRoot linkDirectory notWine} -body { cd $globname file link -symbolic link a1 cd $dir @@ -812,7 +814,7 @@ test filename-11.17.2 {Tcl_GlobCmd} -setup { # Simpler version of the above test to illustrate a given bug. test filename-11.17.3 {Tcl_GlobCmd} -setup { set dir [pwd] -} -constraints {notRoot linkDirectory} -body { +} -constraints {notRoot linkDirectory notWine} -body { cd $globname file link -symbolic link a1 cd $dir @@ -827,7 +829,7 @@ test filename-11.17.3 {Tcl_GlobCmd} -setup { # Make sure the bugfix isn't too simple. We don't want to break 'glob -type l' test filename-11.17.4 {Tcl_GlobCmd} -setup { set dir [pwd] -} -constraints {notRoot linkDirectory} -body { +} -constraints {notRoot linkDirectory notWine} -body { cd $globname file link -symbolic link a1 cd $dir @@ -845,7 +847,7 @@ test filename-11.17.6 {Tcl_GlobCmd} { [list "weird name.c" x,z1.c x1.c y1.c z1.c]]] test filename-11.17.7 {Tcl_GlobCmd: broken link and glob -l} -setup { set dir [pwd] -} -constraints {linkDirectory} -body { +} -constraints {linkDirectory notWine} -body { cd $globname file mkdir nonexistent file link -symbolic link nonexistent @@ -877,7 +879,7 @@ test filename-11.18 {Tcl_GlobCmd} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.18.1 {Tcl_GlobCmd} {win} { +test filename-11.18.1 {Tcl_GlobCmd} {win notWine} { lsort [glob -path $globname/ *] } [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname .1]\ @@ -894,7 +896,7 @@ test filename-11.19 {Tcl_GlobCmd} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.19.1 {Tcl_GlobCmd} {win} { +test filename-11.19.1 {Tcl_GlobCmd} {win notWine} { lsort [glob -join -path [string range $globname 0 5] * *] } [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname .1]\ @@ -903,7 +905,7 @@ test filename-11.19.1 {Tcl_GlobCmd} {win} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.20 {Tcl_GlobCmd} { +test filename-11.20 {Tcl_GlobCmd} notWine { lsort [glob -type d -dir $globname *] } [lsort [list [file join $globname a1]\ [file join $globname a2]\ @@ -933,7 +935,7 @@ test filename-11.22 {Tcl_GlobCmd} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.22.1 {Tcl_GlobCmd} {win} { +test filename-11.22.1 {Tcl_GlobCmd} {win notWine} { lsort [glob -dir $globname *] } [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname .1]\ @@ -950,7 +952,7 @@ test filename-11.23 {Tcl_GlobCmd} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.23.1 {Tcl_GlobCmd} {win} { +test filename-11.23.1 {Tcl_GlobCmd} {win notWine} { lsort [glob -path $globname/ *] } [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname .1]\ @@ -967,7 +969,7 @@ test filename-11.24 {Tcl_GlobCmd} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.24.1 {Tcl_GlobCmd} {win} { +test filename-11.24.1 {Tcl_GlobCmd} {win notWine} { lsort [glob -join -path [string range $globname 0 5] * *] } [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname .1]\ @@ -976,17 +978,17 @@ test filename-11.24.1 {Tcl_GlobCmd} {win} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.25 {Tcl_GlobCmd} { +test filename-11.25 {Tcl_GlobCmd} notWine { lsort [glob -type d -dir $globname *] } [lsort [list [file join $globname a1]\ [file join $globname a2]\ [file join $globname a3]]] -test filename-11.25.1 {Tcl_GlobCmd} { +test filename-11.25.1 {Tcl_GlobCmd} notWine { lsort [glob -type {d r} -dir $globname *] } [lsort [list [file join $globname a1]\ [file join $globname a2]\ [file join $globname a3]]] -test filename-11.25.2 {Tcl_GlobCmd} { +test filename-11.25.2 {Tcl_GlobCmd} notWine { lsort [glob -type {d r w} -dir $globname *] } [lsort [list [file join $globname a1]\ [file join $globname a2]\ @@ -1083,6 +1085,12 @@ test filename-11.48 {Tcl_GlobCmd} -returnCodes error -body { test filename-11.49 {Tcl_GlobCmd} -returnCodes error -body { glob -types abcde -path foo -join * * } -result {bad argument to "-types": abcde} +test filename-11.50 {Tcl_GlobCmd} -returnCodes error -body { + glob -path hello -path salut * +} -result {"-path" may only be used once} +test filename-11.51 {Tcl_GlobCmd} -returnCodes error -body { + glob -dir hello -dir salut * +} -result {"-directory" may only be used once} file rename $horribleglobname globTest file delete -force $tildeglobname @@ -1224,10 +1232,10 @@ test filename-14.5 {asterisks, question marks, and brackets} -setup { test filename-14.7 {asterisks, question marks, and brackets} {unix} { lsort [glob globTest/*] } {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} -test filename-14.7.1 {asterisks, question marks, and brackets} {win} { +test filename-14.7.1 {asterisks, question marks, and brackets} {win notWine} { lsort [glob globTest/*] } {globTest/.1 globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} -test filename-14.9 {asterisks, question marks, and brackets} {unixOrWin} { +test filename-14.9 {asterisks, question marks, and brackets} {unixOrWin notWine} { lsort [glob globTest/.*] } {globTest/. globTest/.. globTest/.1} test filename-14.11 {asterisks, question marks, and brackets} {unixOrWin} { @@ -1236,7 +1244,7 @@ test filename-14.11 {asterisks, question marks, and brackets} {unixOrWin} { test filename-14.13 {asterisks, question marks, and brackets} {unixOrWin} { lsort [glob {globTest/[xyab]1.*}] } {globTest/x1.c globTest/y1.c} -test filename-14.15 {asterisks, question marks, and brackets} {unixOrWin} { +test filename-14.15 {asterisks, question marks, and brackets} {unixOrWin notWine} { lsort [glob globTest/*/] } {globTest/a1/ globTest/a2/ globTest/a3/} test filename-14.17 {asterisks, question marks, and brackets} -setup { @@ -1276,7 +1284,7 @@ test filename-14.25 {type specific globbing} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-14.25.1 {type specific globbing} {win} { +test filename-14.25.1 {type specific globbing} {win notWine} { lsort [glob -dir globTest -types f *] } [lsort [list \ [file join $globname .1]\ diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 361542d..19066ee 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -9,9 +9,12 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 namespace eval ::tcl::test::fileSystem { - namespace import ::tcltest::* + + if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* + } catch { file delete -force link.file diff --git a/tests/fileSystemEncoding.test b/tests/fileSystemEncoding.test index 0f8a2a7..6561bef 100644 --- a/tests/fileSystemEncoding.test +++ b/tests/fileSystemEncoding.test @@ -7,8 +7,11 @@ if {[string equal $::tcl_platform(os) "Windows NT"]} { } namespace eval ::tcl::test::fileSystemEncoding { - package require tcltest 2 - namespace import ::tcltest::* + + if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* + } variable fname1 \u767b\u9e1b\u9d72\u6a13 diff --git a/tests/for-old.test b/tests/for-old.test index bf69376..d00a4ee 100644 --- a/tests/for-old.test +++ b/tests/for-old.test @@ -13,7 +13,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/for.test b/tests/for.test index bc2f40e..239e4d6 100644 --- a/tests/for.test +++ b/tests/for.test @@ -10,7 +10,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/foreach.test b/tests/foreach.test index 6ef608e..cdbfc85 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -11,7 +11,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/format.test b/tests/format.test index ded8a4c..8d6fd82 100644 --- a/tests/format.test +++ b/tests/format.test @@ -11,7 +11,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/get.test b/tests/get.test index e39097c..9e7728a 100644 --- a/tests/get.test +++ b/tests/get.test @@ -11,7 +11,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/history.test b/tests/history.test index 9ff41f2..922d984 100644 --- a/tests/history.test +++ b/tests/history.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/http.test b/tests/http.test index 8eac3c3..a525691 100644 --- a/tests/http.test +++ b/tests/http.test @@ -11,15 +11,17 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} if {[catch {package require http 2} version]} { if {[info exists http2]} { catch {puts "Cannot load http 2.* package"} return } else { - catch {puts "Running http 2.* tests in slave interp"} + catch {puts "Running http 2.* tests in child interp"} set interp [interp create http2] $interp eval [list set http2 "running"] $interp eval [list set argv $argv] @@ -442,6 +444,9 @@ test http-3.33 {http::geturl application/xml is text} -body { } -cleanup { catch { http::cleanup $token } } -result {test 4660 /test} +test http-3.34 {http::geturl -headers not a dict} -returnCodes error -body { + http::geturl http://test/t -headers NoDict +} -result {Bad value for -headers (NoDict), must be dict} test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] diff --git a/tests/http11.test b/tests/http11.test index 762788e..f243e56 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -7,8 +7,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} package require http 2.9 @@ -17,7 +19,7 @@ variable httpd_output proc create_httpd {} { proc httpd_read {chan} { variable httpd_output - if {[gets $chan line] != -1} { + if {[gets $chan line] >= 0} { #puts stderr "read '$line'" set httpd_output $line } @@ -280,6 +282,20 @@ test http11-1.13 "normal, 1.1 and keepalive as server default, no zip" -setup { # ------------------------------------------------------------------------- +proc progress {var token total current} { + upvar #0 $var log + set log [list $current $total] + return +} + +proc progressPause {var token total current} { + upvar #0 $var log + set log [list $current $total] + after 100 set ::WaitHere 0 + vwait ::WaitHere + return +} + test http11-2.0 "-channel" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] @@ -376,6 +392,58 @@ test http11-2.4 "-channel,encoding identity" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {} chunked} +test http11-2.4.1 "-channel,encoding identity with -progress" -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ + -timeout 5000 -channel $chan \ + -headers {accept-encoding identity} \ + -progress [namespace code [list progress logdata]]] + + http::wait $tok + seek $chan 0 + set data [read $chan] + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ + [meta $tok connection] [meta $tok content-encoding]\ + [meta $tok transfer-encoding] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $data]}] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd + unset -nocomplain logdata data +} -result {ok {HTTP/1.1 200 OK} ok close {} chunked 0 0} + +test http11-2.4.2 "-channel,encoding identity with -progress progressPause enters event loop" -constraints knownBug -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ + -timeout 5000 -channel $chan \ + -headers {accept-encoding identity} \ + -progress [namespace code [list progressPause logdata]]] + + http::wait $tok + seek $chan 0 + set data [read $chan] + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ + [meta $tok connection] [meta $tok content-encoding]\ + [meta $tok transfer-encoding] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $data]}] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd + unset -nocomplain logdata data ::WaitHere +} -result {ok {HTTP/1.1 200 OK} ok close {} chunked 0 0} + test http11-2.5 "-channel,encoding unsupported" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] @@ -555,6 +623,16 @@ proc handler {var sock token} { return [string length $chunk] } +proc handlerPause {var sock token} { + upvar #0 $var data + set chunk [read $sock] + append data $chunk + #::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])" + after 100 set ::WaitHere 0 + vwait ::WaitHere + return [string length $chunk] +} + test http11-3.0 "-handler,close,identity" -setup { variable httpd [create_httpd] set testdata "" @@ -626,6 +704,135 @@ test http11-3.3 "-handler,keepalive,chunked" -setup { halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} +# http11-3.4 +# This test is a blatant attempt to confuse the client by instructing the server +# to send neither "Connection: close" nor "Content-Length" when in non-chunked +# mode. +# The client has no way to know the response-body is complete unless the +# server signals this by closing the connection. +# In an HTTP/1.1 response the absence of "Connection: close" means +# "Connection: keep-alive", i.e. the server will keep the connection +# open. In HTTP/1.0 this is not the case, and this is a test that +# the Tcl client assumes "Connection: close" by default in HTTP/1.0. +test http11-3.4 "-handler,close,identity; HTTP/1.0 server does not send Connection: close header or Content-Length" -setup { + variable httpd [create_httpd] + set testdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&nosendclose=any \ + -timeout 10000 -handler [namespace code [list handler testdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok {} {} {} 0} + +# It is not forbidden for a handler to enter the event loop. +test http11-3.5 "-handler,close,identity as http11-3.0 but handlerPause enters event loop" -setup { + variable httpd [create_httpd] + set testdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 -handler [namespace code [list handlerPause testdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} + +test http11-3.6 "-handler,close,identity as http11-3.0 but with -progress" -setup { + variable httpd [create_httpd] + set testdata "" + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 -handler [namespace code [list handler testdata]] \ + -progress [namespace code [list progress logdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0 0 0} + +test http11-3.7 "-handler,close,identity as http11-3.0 but with -progress progressPause enters event loop" -setup { + variable httpd [create_httpd] + set testdata "" + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 -handler [namespace code [list handler testdata]] \ + -progress [namespace code [list progressPause logdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0 0 0} + +test http11-3.8 "close,identity no -handler but with -progress" -setup { + variable httpd [create_httpd] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 \ + -progress [namespace code [list progress logdata]] \ + -headers {accept-encoding {}}] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length [http::data $tok]]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length [http::data $tok]]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0} + +test http11-3.9 "close,identity no -handler but with -progress progressPause enters event loop" -setup { + variable httpd [create_httpd] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 \ + -progress [namespace code [list progressPause logdata]] \ + -headers {accept-encoding {}}] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length [http::data $tok]]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length [http::data $tok]]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0} + test http11-4.0 "normal post request" -setup { variable httpd [create_httpd] } -body { diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test index de1a7d8..4306149 100644 --- a/tests/httpPipeline.test +++ b/tests/httpPipeline.test @@ -8,8 +8,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} package require http 2.9 diff --git a/tests/httpTest.tcl b/tests/httpTest.tcl index 4345845..8a96d95 100644 --- a/tests/httpTest.tcl +++ b/tests/httpTest.tcl @@ -60,7 +60,7 @@ proc http::Log {args} { variable TestStartTimeInMs set time [expr {[clock milliseconds] - $TestStartTimeInMs}] set txt [list $time {*}$args] - if {[string first ^ $txt] != -1} { + if {[string first ^ $txt] >= 0} { ::httpTest::LogRecord $txt ::httpTest::Puts $txt } elseif {$::httpTest::testOptions(-verbose) > 1} { @@ -86,7 +86,7 @@ proc httpTest::LogRecord {txt} { puts stdout "Fix this call to Log in http-*.tm so it has ^ then\ a letter then a numeral." flush stdout - } elseif {$pos == -1} { + } elseif {$pos < 0} { # Called by mistake. } else { set letter [string index $txt [incr pos]] @@ -153,7 +153,7 @@ proc httpTest::TestOverlaps {someResults n term msg badTrans notPiped} { set myStart [lsearch -exact $someResults [list B $i]] set myEnd [lsearch -exact $someResults [list $term $i]] - if {($myStart == -1 || $myEnd == -1)} { + if {($myStart < 0 || $myEnd < 0)} { set res "Cannot find positions of transaction $i" append msg $res \n Puts $res @@ -374,7 +374,7 @@ proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPip variable testOptions set nextRetry [lsearch -glob -index 0 $someResults {[PQR]}] - if {$nextRetry == -1} { + if {$nextRetry < 0} { return [MostAnalysis $someResults $n $msg $skipOverlaps $notIncluded $notPiped] } set badTrans $notIncluded @@ -391,7 +391,7 @@ proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPip for {set i 1} {$i <= $n} {incr i} { set first [lsearch -exact $beforeTry [list A $i]] set last [lsearch -exact $beforeTry [list F $i]] - if {$first == -1} { + if {$first < 0} { set res "Transaction $i was not started in connection number $tryCount" # So lappend it to badTrans and don't include it in the call below of MostAnalysis. # append msg $res \n @@ -400,7 +400,7 @@ proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPip lappend badTrans $i } else { } - } elseif {$last == -1} { + } elseif {$last < 0} { set res "Transaction $i was started but unfinished in connection number $tryCount" # So lappend it to badTrans and don't include it in the call below of MostAnalysis. # append msg $res \n diff --git a/tests/httpcookie.test b/tests/httpcookie.test index b3c5412..ca54073 100644 --- a/tests/httpcookie.test +++ b/tests/httpcookie.test @@ -9,8 +9,10 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl index 7880494..89590ec 100644 --- a/tests/httpd11.tcl +++ b/tests/httpd11.tcl @@ -170,14 +170,19 @@ proc Service {chan addr port} { set close 1 } + set nosendclose 0 foreach pair [split $query &] { if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""} switch -exact -- $key { + nosendclose {set nosendclose 1} close {set close 1 ; set transfer 0} transfer {set transfer $val} content-type {set type $val} } } + if {$protocol eq "HTTP/1.1"} { + set nosendclose 0 + } chan configure $chan -buffering line -encoding iso8859-1 -translation crlf Puts $chan "$protocol $code" @@ -186,12 +191,16 @@ proc Service {chan addr port} { if {$req eq "POST"} { Puts $chan [format "x-query-length: %d" [string length $query]] } - if {$close} { + if {$close && (!$nosendclose)} { Puts $chan "connection: close" } Puts $chan "x-requested-encodings: [dict get? $meta accept-encoding]" - if {$encoding eq "identity"} { + if {$encoding eq "identity" && (!$nosendclose)} { Puts $chan "content-length: [string length $data]" + } elseif {$encoding eq "identity"} { + # This is a blatant attempt to confuse the client by sending neither + # "Connection: close" nor "Content-Length" when in non-chunked mode. + # See test http11-3.4. } else { Puts $chan "content-encoding: $encoding" } @@ -228,7 +237,7 @@ proc Accept {chan addr port} { } proc Control {chan} { - if {[gets $chan line] != -1} { + if {[gets $chan line] >= 0} { if {[string trim $line] eq "quit"} { set ::forever 1 } diff --git a/tests/if-old.test b/tests/if-old.test index db23889..e537fea 100644 --- a/tests/if-old.test +++ b/tests/if-old.test @@ -14,7 +14,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/if.test b/tests/if.test index d7fce19..f5acf60 100644 --- a/tests/if.test +++ b/tests/if.test @@ -11,7 +11,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/incr-old.test b/tests/incr-old.test index 77597a5..5d792e1 100644 --- a/tests/incr-old.test +++ b/tests/incr-old.test @@ -14,7 +14,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/incr.test b/tests/incr.test index aa2872a..9d92f85 100644 --- a/tests/incr.test +++ b/tests/incr.test @@ -11,7 +11,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/indexObj.test b/tests/indexObj.test index b70b6d9..079eb52 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -9,7 +9,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/info.test b/tests/info.test index 7ac6d8c..813b418 100644 --- a/tests/info.test +++ b/tests/info.test @@ -16,7 +16,7 @@ # DO NOT DELETE THIS LINE if {{::tcltest} ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands diff --git a/tests/init.test b/tests/init.test index 91df4a1..a607ff0 100644 --- a/tests/init.test +++ b/tests/init.test @@ -11,7 +11,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.3.4 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/interp.test b/tests/interp.test index 599ac08..f428207 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -11,7 +11,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -22,7 +22,7 @@ testConstraint testinterpdelete [llength [info commands testinterpdelete]] set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload} -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } @@ -32,7 +32,7 @@ test interp-1.1 {options for interp command} -returnCodes error -body { } -result {wrong # args: should be "interp cmd ?arg ...?"} test interp-1.2 {options for interp command} -returnCodes error -body { interp frobox -} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} test interp-1.3 {options for interp command} { interp delete } "" @@ -46,17 +46,17 @@ test interp-1.5 {options for interp command} -returnCodes error -body { # test interp-0.6 was removed # test interp-1.6 {options for interp command} -returnCodes error -body { - interp slaves foo bar zop -} -result {wrong # args: should be "interp slaves ?path?"} + interp children foo bar zop +} -result {wrong # args: should be "interp children ?path?"} test interp-1.7 {options for interp command} -returnCodes error -body { interp hello -} -result {bad option "hello": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "hello": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} test interp-1.8 {options for interp command} -returnCodes error -body { interp -froboz -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} test interp-1.9 {options for interp command} -returnCodes error -body { interp -froboz -safe -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} test interp-1.10 {options for interp command} -returnCodes error -body { interp target } -result {wrong # args: should be "interp target path alias"} @@ -120,45 +120,45 @@ test interp-2.13 {correct default when no $path arg is given} -body { interp create -- } -match regexp -result {interp[0-9]+} -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } -# Part 2: Testing "interp slaves" and "interp exists" -test interp-3.1 {testing interp exists and interp slaves} { - interp slaves +# Part 2: Testing "interp children" and "interp exists" +test interp-3.1 {testing interp exists and interp children} { + interp children } "" -test interp-3.2 {testing interp exists and interp slaves} { +test interp-3.2 {testing interp exists and interp children} { interp create a interp exists a } 1 -test interp-3.3 {testing interp exists and interp slaves} { +test interp-3.3 {testing interp exists and interp children} { interp exists nonexistent } 0 -test interp-3.4 {testing interp exists and interp slaves} -body { - interp slaves a b c -} -returnCodes error -result {wrong # args: should be "interp slaves ?path?"} -test interp-3.5 {testing interp exists and interp slaves} -body { +test interp-3.4 {testing interp exists and interp children} -body { + interp children a b c +} -returnCodes error -result {wrong # args: should be "interp children ?path?"} +test interp-3.5 {testing interp exists and interp children} -body { interp exists a b c } -returnCodes error -result {wrong # args: should be "interp exists ?path?"} -test interp-3.6 {testing interp exists and interp slaves} { +test interp-3.6 {testing interp exists and interp children} { interp exists } 1 -test interp-3.7 {testing interp exists and interp slaves} -setup { +test interp-3.7 {testing interp exists and interp children} -setup { catch {interp create a} } -body { - interp slaves + interp children } -result a -test interp-3.8 {testing interp exists and interp slaves} -body { - interp slaves a b c -} -returnCodes error -result {wrong # args: should be "interp slaves ?path?"} -test interp-3.9 {testing interp exists and interp slaves} -setup { +test interp-3.8 {testing interp exists and interp children} -body { + interp children a b c +} -returnCodes error -result {wrong # args: should be "interp children ?path?"} +test interp-3.9 {testing interp exists and interp children} -setup { catch {interp create a} } -body { interp create {a a2} -safe - expr {"a2" in [interp slaves a]} + expr {"a2" in [interp children a]} } -result 1 -test interp-3.10 {testing interp exists and interp slaves} -setup { +test interp-3.10 {testing interp exists and interp children} -setup { catch {interp create a} catch {interp create {a a2}} } -body { @@ -186,7 +186,7 @@ test interp-4.5 {testing interp delete} { interp create a interp create {a x1} interp delete {a x1} - expr {"x1" in [interp slaves a]} + expr {"x1" in [interp children a]} } 0 test interp-4.6 {testing interp delete} { interp create c1 @@ -203,14 +203,14 @@ test interp-4.8 {testing interp delete} -returnCodes error -body { interp delete {} } -result {cannot delete the current interpreter} -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } # Part 4: Consistency checking - all nondeleted interpreters should be # there: test interp-5.1 {testing consistency} { - interp slaves + interp children } "" test interp-5.2 {testing consistency} { interp exists a @@ -247,27 +247,27 @@ test interp-6.6 {testing eval} -returnCodes error -body { interp eval {a x2} foo } -result {invalid command name "foo"} -# UTILITY PROCEDURE RUNNING IN MASTER INTERPRETER: -proc in_master {args} { - return [list seen in master: $args] +# UTILITY PROCEDURE RUNNING IN PARENT INTERPRETER: +proc in_parent {args} { + return [list seen in parent: $args] } # Part 6: Testing basic alias creation test interp-7.1 {testing basic alias creation} { - a alias foo in_master + a alias foo in_parent } foo -catch {a alias foo in_master} +catch {a alias foo in_parent} test interp-7.2 {testing basic alias creation} { - a alias bar in_master a1 a2 a3 + a alias bar in_parent a1 a2 a3 } bar -catch {a alias bar in_master a1 a2 a3} +catch {a alias bar in_parent a1 a2 a3} # Test 6.3 has been deleted. test interp-7.3 {testing basic alias creation} { a alias foo -} in_master +} in_parent test interp-7.4 {testing basic alias creation} { a alias bar -} {in_master a1 a2 a3} +} {in_parent a1 a2 a3} test interp-7.5 {testing basic alias creation} { lsort [a aliases] } {bar foo} @@ -278,14 +278,14 @@ test interp-7.6 {testing basic aliases arg checking} -returnCodes error -body { # Part 7: testing basic alias invocation test interp-8.1 {testing basic alias invocation} { catch {interp create a} - a alias foo in_master + a alias foo in_parent a eval foo s1 s2 s3 -} {seen in master: {s1 s2 s3}} +} {seen in parent: {s1 s2 s3}} test interp-8.2 {testing basic alias invocation} { catch {interp create a} - a alias bar in_master a1 a2 a3 + a alias bar in_parent a1 a2 a3 a eval bar s1 s2 s3 -} {seen in master: {a1 a2 a3 s1 s2 s3}} +} {seen in parent: {a1 a2 a3 s1 s2 s3}} test interp-8.3 {testing basic alias invocation} -returnCodes error -body { catch {interp create a} a alias @@ -294,13 +294,13 @@ test interp-8.3 {testing basic alias invocation} -returnCodes error -body { # Part 8: Testing aliases for non-existent or hidden targets test interp-9.1 {testing aliases for non-existent targets} { catch {interp create a} - a alias zop nonexistent-command-in-master + a alias zop nonexistent-command-in-parent list [catch {a eval zop} msg] $msg -} {1 {invalid command name "nonexistent-command-in-master"}} +} {1 {invalid command name "nonexistent-command-in-parent"}} test interp-9.2 {testing aliases for non-existent targets} { catch {interp create a} - a alias zop nonexistent-command-in-master - proc nonexistent-command-in-master {} {return i_exist!} + a alias zop nonexistent-command-in-parent + proc nonexistent-command-in-parent {} {return i_exist!} a eval zop } i_exist! test interp-9.3 {testing aliases for hidden commands} { @@ -329,8 +329,8 @@ test interp-9.4 {testing aliases and namespace commands} { set res } {GLOBAL GLOBAL} -if {[info command nonexistent-command-in-master] != ""} { - rename nonexistent-command-in-master {} +if {[info command nonexistent-command-in-parent] != ""} { + rename nonexistent-command-in-parent {} } # Part 9: Aliasing between interpreters @@ -380,9 +380,9 @@ test interp-10.6 {testing aliasing between interpreters} { interp create a interp create b interp alias a a_command b b_command a1 a2 a3 - b alias b_command in_master b1 b2 b3 + b alias b_command in_parent b1 b2 b3 a eval a_command m1 m2 m3 -} {seen in master: {b1 b2 b3 a1 a2 a3 m1 m2 m3}} +} {seen in parent: {b1 b2 b3 a1 a2 a3 m1 m2 m3}} test interp-10.7 {testing aliases between interpreters} { catch {interp delete a} interp create a @@ -513,7 +513,7 @@ test interp-14.3 {testing interp aliases} { interp alias {a x3} froboz "" puts interp aliases {a x3} } froboz -test interp-14.4 {testing interp alias - alias over master} { +test interp-14.4 {testing interp alias - alias over parent} { # SF Bug 641195 catch {interp delete a} interp create a @@ -793,32 +793,32 @@ test interp-17.6 {alias loop prevention} { } {1 {cannot define or rename alias "b": would create a loop}} # -# Test robustness of Tcl_DeleteInterp when applied to a slave interpreter. +# Test robustness of Tcl_DeleteInterp when applied to a child interpreter. # If there are bugs in the implementation these tests are likely to expose # the bugs as a core dump. # -test interp-18.1 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.1 {testing Tcl_DeleteInterp vs children} testinterpdelete { list [catch {testinterpdelete} msg] $msg } {1 {wrong # args: should be "testinterpdelete path"}} -test interp-18.2 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.2 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a testinterpdelete a } "" -test interp-18.3 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.3 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} testinterpdelete {a b} } "" -test interp-18.4 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.4 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} testinterpdelete a } "" -test interp-18.5 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.5 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} @@ -826,7 +826,7 @@ test interp-18.5 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { proc dodel {x} {testinterpdelete $x} list [catch {interp eval {a b} {dodel {a b}}} msg] $msg } {0 {}} -test interp-18.6 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.6 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} @@ -1615,36 +1615,36 @@ test interp-20.49 {interp invokehidden -namespace} -setup { set script [makeFile { set x [namespace current] } script] - interp create -safe slave + interp create -safe child } -body { - slave invokehidden -namespace ::foo source $script - slave eval {set ::foo::x} + child invokehidden -namespace ::foo source $script + child eval {set ::foo::x} } -cleanup { - interp delete slave + interp delete child removeFile script } -result ::foo test interp-20.50 {Bug 2486550} -setup { - interp create slave + interp create child } -body { - slave hide coroutine - slave invokehidden coroutine + child hide coroutine + child invokehidden coroutine } -cleanup { - interp delete slave + interp delete child } -returnCodes error -match glob -result * test interp-20.50.1 {Bug 2486550} -setup { - interp create slave + interp create child } -body { - slave hide coroutine - catch {slave invokehidden coroutine} m o + child hide coroutine + catch {child invokehidden coroutine} m o dict get $o -errorinfo } -cleanup { unset -nocomplain m 0 - interp delete slave + interp delete child } -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?" while executing "coroutine" invoked from within -"slave invokehidden coroutine"} +"child invokehidden coroutine"} test interp-21.1 {interp hidden} { interp hidden {} @@ -2058,8 +2058,8 @@ test interp-25.1 {testing aliasing of string commands} -setup { test interp-26.1 {result code transmission : interp eval direct} { # Test that all the possibles error codes from Tcl get passed up - # from the slave interp's context to the master, even though the - # slave nominally thinks the command is running at the root level. + # from the child interp's context to the parent, even though the + # child nominally thinks the command is running at the root level. catch {interp delete a} interp create a set res {} @@ -2085,7 +2085,7 @@ test interp-26.2 {result code transmission : interp eval indirect} { } {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} test interp-26.3 {result code transmission : aliases} { # Test that all the possibles error codes from Tcl get passed up from the - # slave interp's context to the master, even though the slave nominally + # child interp's context to the parent, even though the child nominally # thinks the command is running at the root level. catch {interp delete a} interp create a @@ -2180,7 +2180,7 @@ test interp-26.8 {errorInfo transmission: safe interps--bug 1637} -setup { } -constraints knownBug -body { # this test fails because the errorInfo is fully transmitted whether the # interp is safe or not. The errorInfo should never report data from the - # master interpreter because it could contain sensitive information. + # parent interpreter because it could contain sensitive information. proc MyError {secret} { return -code error "msg" } @@ -2275,22 +2275,22 @@ test interp-27.5 {interp hidden & namespaces} -setup { test interp-27.6 {interp hidden & aliases & namespaces} -setup { set i [interp create] } -constraints knownBug -body { - set v root-master + set v root-parent namespace eval foo { - variable v foo-master + variable v foo-parent proc bar {interp args} { variable v - list "master bar called ($v) ([namespace current]) ($args)"\ + list "parent bar called ($v) ([namespace current]) ($args)"\ [interp invokehidden $interp foo::bar $args] } } interp eval $i { namespace eval foo { namespace export * - variable v foo-slave + variable v foo-child proc bar {args} { variable v - return "slave bar called ($v) ([namespace current]) ($args)" + return "child bar called ($v) ([namespace current]) ($args)" } } } @@ -2298,7 +2298,7 @@ test interp-27.6 {interp hidden & aliases & namespaces} -setup { $i hide foo::bar $i alias foo::bar foo::bar $i set res [concat $res [interp eval $i { - set v root-slave + set v root-child namespace eval test { variable v foo-test namespace import ::foo::* @@ -2308,29 +2308,29 @@ test interp-27.6 {interp hidden & aliases & namespaces} -setup { } -cleanup { namespace delete foo interp delete $i -} -result {{slave bar called (foo-slave) (::foo) (test1)} {master bar called (foo-master) (::foo) (test2)} {slave bar called (foo-slave) (::foo) (test2)}} +} -result {{child bar called (foo-child) (::foo) (test1)} {parent bar called (foo-parent) (::foo) (test2)} {child bar called (foo-child) (::foo) (test2)}} test interp-27.7 {interp hidden & aliases & imports & namespaces} -setup { set i [interp create] } -constraints knownBug -body { - set v root-master + set v root-parent namespace eval mfoo { - variable v foo-master + variable v foo-parent proc bar {interp args} { variable v - list "master bar called ($v) ([namespace current]) ($args)"\ + list "parent bar called ($v) ([namespace current]) ($args)"\ [interp invokehidden $interp test::bar $args] } } interp eval $i { namespace eval foo { namespace export * - variable v foo-slave + variable v foo-child proc bar {args} { variable v - return "slave bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)" + return "child bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)" } } - set v root-slave + set v root-child namespace eval test { variable v foo-test namespace import ::foo::* @@ -2343,7 +2343,7 @@ test interp-27.7 {interp hidden & aliases & imports & namespaces} -setup { } -cleanup { namespace delete mfoo interp delete $i -} -result {{slave bar called (foo-slave) (bar test1) (::tcltest) (::foo) (test1)} {master bar called (foo-master) (::mfoo) (test2)} {slave bar called (foo-slave) (test::bar test2) (::) (::foo) (test2)}} +} -result {{child bar called (foo-child) (bar test1) (::tcltest) (::foo) (test1)} {parent bar called (foo-parent) (::mfoo) (test2)} {child bar called (foo-child) (test::bar test2) (::) (::foo) (test2)}} test interp-27.8 {hiding, namespaces and integrity} knownBug { namespace eval foo { variable v 3 @@ -2355,25 +2355,25 @@ test interp-27.8 {hiding, namespaces and integrity} knownBug { list [catch {interp invokehidden {} foo::bar} msg] $msg } {1 {invalid hidden command name "foo"}} -test interp-28.1 {getting fooled by slave's namespace ?} -setup { +test interp-28.1 {getting fooled by child's namespace ?} -setup { set i [interp create -safe] - proc master {interp args} {interp hide $interp list} + proc parent {interp args} {interp hide $interp list} } -body { - $i alias master master $i + $i alias parent parent $i set r [interp eval $i { namespace eval foo { proc list {args} { return "dummy foo::list" } - master + parent } info commands list }] } -cleanup { - rename master {} + rename parent {} interp delete $i } -result {} -test interp-28.2 {master's nsName cache should not cross} -setup { +test interp-28.2 {parent's nsName cache should not cross} -setup { set i [interp create] $i eval {proc filter lst {lsearch -all -inline -not $lst "::tcl"}} } -body { @@ -2432,31 +2432,31 @@ test interp-29.1.7 {interp recursionlimit argument checking} { interp delete moo list $result [string range $msg 0 35] } {1 {integer value too large to represent}} -test interp-29.1.8 {slave recursionlimit argument checking} { +test interp-29.1.8 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit foo bar} msg] interp delete moo list $result $msg } {1 {wrong # args: should be "moo recursionlimit ?newlimit?"}} -test interp-29.1.9 {slave recursionlimit argument checking} { +test interp-29.1.9 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit foo} msg] interp delete moo list $result $msg } {1 {expected integer but got "foo"}} -test interp-29.1.10 {slave recursionlimit argument checking} { +test interp-29.1.10 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit 0} msg] interp delete moo list $result $msg } {1 {recursion limit must be > 0}} -test interp-29.1.11 {slave recursionlimit argument checking} { +test interp-29.1.11 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit -1} msg] interp delete moo list $result $msg } {1 {recursion limit must be > 0}} -test interp-29.1.12 {slave recursionlimit argument checking} { +test interp-29.1.12 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit [expr {wide(1)<<32}]} msg] interp delete moo @@ -2549,8 +2549,8 @@ test interp-29.3.3 {recursion limit} { set r } {1 {too many nested evaluations (infinite loop?)} 49} test interp-29.3.4 {recursion limit error reporting} { - interp create slave - set r1 [slave eval { + interp create child + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2564,13 +2564,13 @@ test interp-29.3.4 {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {falling back due to new recursion limit}} test interp-29.3.5 {recursion limit error reporting} { - interp create slave - set r1 [slave eval { + interp create child + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2584,13 +2584,13 @@ test interp-29.3.5 {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {falling back due to new recursion limit}} test interp-29.3.6 {recursion limit error reporting} { - interp create slave - set r1 [slave eval { + interp create child + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2604,8 +2604,8 @@ test interp-29.3.6 {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} # @@ -2613,9 +2613,9 @@ test interp-29.3.6 {recursion limit error reporting} { # level will only be verified when it invokes a non-bcc'd command. # test interp-29.3.7a {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 5} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2629,14 +2629,14 @@ test interp-29.3.7a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.7b {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 5} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2650,14 +2650,14 @@ test interp-29.3.7b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.7c {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 5} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2672,14 +2672,14 @@ test interp-29.3.7c {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.8a {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 4} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 4} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2693,14 +2693,14 @@ test interp-29.3.8a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.8b {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 4} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 4} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2714,14 +2714,14 @@ test interp-29.3.8b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.9a {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 6} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2735,14 +2735,14 @@ test interp-29.3.9a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.9b {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 6} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2756,14 +2756,14 @@ test interp-29.3.9b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.10a {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 4} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 4} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2777,14 +2777,14 @@ test interp-29.3.10a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.10b {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 4} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 4} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2798,14 +2798,14 @@ test interp-29.3.10b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.11a {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 5} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2819,14 +2819,14 @@ test interp-29.3.11a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.11b {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 5} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2841,14 +2841,14 @@ test interp-29.3.11b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.12a {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 6} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2862,14 +2862,14 @@ test interp-29.3.12a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.12b {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 6} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2884,8 +2884,8 @@ test interp-29.3.12b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.4.1 {recursion limit inheritance} { @@ -2916,121 +2916,121 @@ test interp-29.4.2 {recursion limit inheritance} { interp delete $i set r } 50 -test interp-29.5.1 {does slave recursion limit affect master?} { +test interp-29.5.1 {does child recursion limit affect parent?} { set before [interp recursionlimit {}] set i [interp create] interp recursionlimit $i 20000 set after [interp recursionlimit {}] - set slavelimit [interp recursionlimit $i] + set childlimit [interp recursionlimit $i] interp delete $i - list [expr {$before == $after}] $slavelimit + list [expr {$before == $after}] $childlimit } {1 20000} -test interp-29.5.2 {does slave recursion limit affect master?} { +test interp-29.5.2 {does child recursion limit affect parent?} { set before [interp recursionlimit {}] set i [interp create] interp recursionlimit $i 20000 set after [interp recursionlimit {}] - set slavelimit [$i recursionlimit] + set childlimit [$i recursionlimit] interp delete $i - list [expr {$before == $after}] $slavelimit + list [expr {$before == $after}] $childlimit } {1 20000} -test interp-29.5.3 {does slave recursion limit affect master?} { +test interp-29.5.3 {does child recursion limit affect parent?} { set before [interp recursionlimit {}] set i [interp create] $i recursionlimit 20000 set after [interp recursionlimit {}] - set slavelimit [interp recursionlimit $i] + set childlimit [interp recursionlimit $i] interp delete $i - list [expr {$before == $after}] $slavelimit + list [expr {$before == $after}] $childlimit } {1 20000} -test interp-29.5.4 {does slave recursion limit affect master?} { +test interp-29.5.4 {does child recursion limit affect parent?} { set before [interp recursionlimit {}] set i [interp create] $i recursionlimit 20000 set after [interp recursionlimit {}] - set slavelimit [$i recursionlimit] + set childlimit [$i recursionlimit] interp delete $i - list [expr {$before == $after}] $slavelimit + list [expr {$before == $after}] $childlimit } {1 20000} test interp-29.6.1 {safe interpreter recursion limit} { - interp create slave -safe - set n [interp recursionlimit slave] - interp delete slave + interp create child -safe + set n [interp recursionlimit child] + interp delete child set n } 1000 test interp-29.6.2 {safe interpreter recursion limit} { - interp create slave -safe - set n [slave recursionlimit] - interp delete slave + interp create child -safe + set n [child recursionlimit] + interp delete child set n } 1000 test interp-29.6.3 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [interp recursionlimit slave 42] - set n2 [interp recursionlimit slave] - interp delete slave + interp create child -safe + set n1 [interp recursionlimit child 42] + set n2 [interp recursionlimit child] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.4 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [slave recursionlimit 42] - set n2 [interp recursionlimit slave] - interp delete slave + interp create child -safe + set n1 [child recursionlimit 42] + set n2 [interp recursionlimit child] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.5 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [interp recursionlimit slave 42] - set n2 [slave recursionlimit] - interp delete slave + interp create child -safe + set n1 [interp recursionlimit child 42] + set n2 [child recursionlimit] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.6 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [slave recursionlimit 42] - set n2 [slave recursionlimit] - interp delete slave + interp create child -safe + set n1 [child recursionlimit 42] + set n2 [child recursionlimit] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.7 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [slave recursionlimit 42] - set n2 [slave recursionlimit] - interp delete slave + interp create child -safe + set n1 [child recursionlimit 42] + set n2 [child recursionlimit] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.8 {safe interpreter recursion limit} { - interp create slave -safe - set n [catch {slave eval {interp recursionlimit {} 42}} msg] - interp delete slave + interp create child -safe + set n [catch {child eval {interp recursionlimit {} 42}} msg] + interp delete child list $n $msg } {1 {permission denied: safe interpreters cannot change recursion limit}} test interp-29.6.9 {safe interpreter recursion limit} { - interp create slave -safe + interp create child -safe set result [ - slave eval { - interp create slave2 -safe + child eval { + interp create child2 -safe set n [catch { - interp recursionlimit slave2 42 + interp recursionlimit child2 42 } msg] list $n $msg } ] - interp delete slave + interp delete child set result } {1 {permission denied: safe interpreters cannot change recursion limit}} test interp-29.6.10 {safe interpreter recursion limit} { - interp create slave -safe + interp create child -safe set result [ - slave eval { - interp create slave2 -safe + child eval { + interp create child2 -safe set n [catch { - slave2 recursionlimit 42 + child2 recursionlimit 42 } msg] list $n $msg } ] - interp delete slave + interp delete child set result } {1 {permission denied: safe interpreters cannot change recursion limit}} @@ -3559,44 +3559,44 @@ test interp-36.2 {interp bgerror syntax} -body { interp bgerror x y z } -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"} test interp-36.3 {interp bgerror syntax} -setup { - interp create slave + interp create child } -body { - slave bgerror x y + child bgerror x y } -cleanup { - interp delete slave -} -returnCodes error -result {wrong # args: should be "slave bgerror ?cmdPrefix?"} -test interp-36.4 {SlaveBgerror syntax} -setup { - interp create slave + interp delete child +} -returnCodes error -result {wrong # args: should be "child bgerror ?cmdPrefix?"} +test interp-36.4 {ChildBgerror syntax} -setup { + interp create child } -body { - slave bgerror \{ + child bgerror \{ } -cleanup { - interp delete slave + interp delete child } -returnCodes error -result {cmdPrefix must be list of length >= 1} -test interp-36.5 {SlaveBgerror syntax} -setup { - interp create slave +test interp-36.5 {ChildBgerror syntax} -setup { + interp create child } -body { - slave bgerror {} + child bgerror {} } -cleanup { - interp delete slave + interp delete child } -returnCodes error -result {cmdPrefix must be list of length >= 1} -test interp-36.6 {SlaveBgerror returns handler} -setup { - interp create slave +test interp-36.6 {ChildBgerror returns handler} -setup { + interp create child } -body { - slave bgerror {foo bar soom} + child bgerror {foo bar soom} } -cleanup { - interp delete slave + interp delete child } -result {foo bar soom} -test interp-36.7 {SlaveBgerror sets error handler of slave [1999035]} -setup { - interp create slave - slave alias handler handler - slave bgerror handler +test interp-36.7 {ChildBgerror sets error handler of child [1999035]} -setup { + interp create child + child alias handler handler + child bgerror handler variable result {untouched} proc handler {args} { variable result set result [lindex $args 0] } } -body { - slave eval { + child eval { variable done {} after 0 error foo after 10 [list ::set [namespace which -variable done] {}] @@ -3606,7 +3606,7 @@ test interp-36.7 {SlaveBgerror sets error handler of slave [1999035]} -setup { } -cleanup { variable result {} unset -nocomplain result - interp delete slave + interp delete child } -result foo test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { @@ -3667,7 +3667,7 @@ test interp-38.8 {interp debug basic setup} -body { # cleanup unset -nocomplain hidden_cmds -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } ::tcltest::cleanupTests diff --git a/tests/io.test b/tests/io.test index ca37870..2752408 100644 --- a/tests/io.test +++ b/tests/io.test @@ -14,7 +14,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 } namespace eval ::tcl::test::io { @@ -44,6 +44,7 @@ testConstraint testmainthread [llength [info commands testmainthread]] testConstraint testobj [llength [info commands testobj]] testConstraint testservicemode [llength [info commands testservicemode]] testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}] +testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] # You need a *very* special environment to do some tests. In # particular, many file systems do not support large-files... @@ -6087,7 +6088,7 @@ test io-45.3 {DeleteFileEvent, cleanup on close} {fileevent} { # Execute these tests only if the "testfevent" command is present. -test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} { +test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent notOSX} { testfevent create set script "set f \[[list open $path(foo) r]]\n" append script { @@ -6895,7 +6896,7 @@ test io-50.4 {testing handler deletion vs reentrant calls} -constraints {testcha } -cleanup { close $f } -result {{delrecursive calling recursive} {delrecursive deleting recursive}} -test io-50.5 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode} -setup { +test io-50.5 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode notOSX} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] @@ -8758,16 +8759,16 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup { set fn [makeFile {} io-74.1] set rfd [open $fn r] testobj freeallvars - interp create slave + interp create child } -constraints testobj -body { teststringobj set 1 [string range $rfd 0 end] read [teststringobj get 1] testobj duplicate 1 2 - interp transfer {} $rfd slave + interp transfer {} $rfd child catch {read [teststringobj get 1]} read [teststringobj get 2] } -cleanup { - interp delete slave + interp delete child testobj freeallvars removeFile io-74.1 } -returnCodes error -match glob -result {can not find channel named "*"} diff --git a/tests/ioCmd.test b/tests/ioCmd.test index d1f1ebe..749d225 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -2084,7 +2084,7 @@ test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body { set ida [interp create];#puts <<$ida>> set idb [interp create];#puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb @@ -2122,7 +2122,7 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m set ida [interp create];#puts <<$ida>> set idb [interp create];#puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb @@ -2164,13 +2164,13 @@ test iocmd-32.2 {delete interp of reflected chan} { # Bug 3034840 # Run this test in an interp with memory debugging to panic # on the double free - interp create slave - slave eval { + interp create child + child eval { proc no-op args {} proc driver {sub args} {return {initialize finalize watch read}} chan event [chan create read driver] readable no-op } - interp delete slave + interp delete child } {} # ### ### ### ######### ######### ######### diff --git a/tests/ioTrans.test b/tests/ioTrans.test index fe85c94..f185117 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -37,7 +37,7 @@ testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] set helperscript { if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -1162,7 +1162,7 @@ test iortrans-8.3 {chan flush, bug 2921116} -match glob -setup { test iortrans-11.0 {origin interpreter of moved transform gone} -setup { set ida [interp create]; #puts <<$ida>> set idb [interp create]; #puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb } -constraints {testchannel} -match glob -body { @@ -1205,7 +1205,7 @@ test iortrans-11.0 {origin interpreter of moved transform gone} -setup { test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup { set ida [interp create]; #puts <<$ida>> set idb [interp create]; #puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb } -constraints {testchannel} -match glob -body { @@ -1244,16 +1244,16 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces tempdone } -result {Owner lost} test iortrans-11.2 {delete interp of reflected transform} -setup { - interp create slave - # Magic to get the test* commands into the slave - load {} Tcltest slave + interp create child + # Magic to get the test* commands into the child + load {} Tcltest child } -constraints {testchannel} -body { - # Get base channel into the slave + # Get base channel into the child set c [tempchan] testchannel cut $c - interp eval slave [list testchannel splice $c] - interp eval slave [list set c $c] - slave eval { + interp eval child [list testchannel splice $c] + interp eval child [list set c $c] + child eval { proc no-op args {} proc driver {c sub args} { return {initialize finalize read write} @@ -1261,7 +1261,7 @@ test iortrans-11.2 {delete interp of reflected transform} -setup { set t [chan push $c [list driver $c]] chan event $c readable no-op } - interp delete slave + interp delete child } -cleanup { tempdone } -result {} diff --git a/tests/iogt.test b/tests/iogt.test index 3cac2cf..fb04b5b 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -10,9 +10,9 @@ # Copyright (c) 2000 Andreas Kupries. # All rights reserved. -if {[catch {package require tcltest 2.1}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.1 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands diff --git a/tests/join.test b/tests/join.test index b29287b..9ea554d 100644 --- a/tests/join.test +++ b/tests/join.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lindex.test b/tests/lindex.test index 41c803b..f9397d2 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -13,7 +13,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -449,6 +449,14 @@ test lindex-17.1 {Bug 1718580} -body { lindex a end foo } -match glob -result {bad index "foo"*} -returnCodes 1 +test lindex-18.0 {nested bytecode execution} -setup { + proc demo {i} {lindex {a b c} $i} +} -body { + demo 0+0x10000000000000000 +} -cleanup { + rename demo {} +} + catch { unset minus } # cleanup diff --git a/tests/link.test b/tests/link.test index 336634b..89e5aa2 100644 --- a/tests/link.test +++ b/tests/link.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/linsert.test b/tests/linsert.test index 2728360..ddc56a9 100644 --- a/tests/linsert.test +++ b/tests/linsert.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/list.test b/tests/list.test index 5477806..edb572c 100644 --- a/tests/list.test +++ b/tests/list.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/listObj.test b/tests/listObj.test index fb6397e..ce6c978 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/llength.test b/tests/llength.test index 469cd5f..a2770c0 100644 --- a/tests/llength.test +++ b/tests/llength.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lmap.test b/tests/lmap.test index 641eac2..3b52c64 100644 --- a/tests/lmap.test +++ b/tests/lmap.test @@ -14,7 +14,7 @@ # RCS: @(#) $Id: $ if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/load.test b/tests/load.test index 13dd7ef..9fdf1cf 100644 --- a/tests/load.test +++ b/tests/load.test @@ -11,7 +11,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -103,7 +103,7 @@ test load-3.1 {error in _Init procedure, same interpreter} \ "if 44 {open non_existent}" invoked from within "load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}} -test load-3.2 {error in _Init procedure, slave interpreter} \ +test load-3.2 {error in _Init procedure, child interpreter} \ [list $dll $loaded] { catch {interp delete x} interp create x diff --git a/tests/lpop.test b/tests/lpop.test index 602e8e0..35f0103 100644 --- a/tests/lpop.test +++ b/tests/lpop.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lrange.test b/tests/lrange.test index 8734078..a20422f 100644 --- a/tests/lrange.test +++ b/tests/lrange.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lrepeat.test b/tests/lrepeat.test index 9ca5ba8..f62f35f 100644 --- a/tests/lrepeat.test +++ b/tests/lrepeat.test @@ -10,7 +10,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lreplace.test b/tests/lreplace.test index d2d5cfb..0b3f7f1 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lsearch.test b/tests/lsearch.test index 2086615..6d183ad 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lset.test b/tests/lset.test index 3fdec90..d98a38e 100644 --- a/tests/lset.test +++ b/tests/lset.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lsetComp.test b/tests/lsetComp.test index c13d23e..d313bbc 100644 --- a/tests/lsetComp.test +++ b/tests/lsetComp.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/macOSXFCmd.test b/tests/macOSXFCmd.test index 08cedd7..0a147f0 100644 --- a/tests/macOSXFCmd.test +++ b/tests/macOSXFCmd.test @@ -10,7 +10,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/macOSXLoad.test b/tests/macOSXLoad.test index fb56d7d..ea4a910 100644 --- a/tests/macOSXLoad.test +++ b/tests/macOSXLoad.test @@ -11,7 +11,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } set oldTSF $::tcltest::testSingleFile diff --git a/tests/main.test b/tests/main.test index 0398d36..c7347b9 100644 --- a/tests/main.test +++ b/tests/main.test @@ -1,8 +1,8 @@ # This file contains a collection of tests for generic/tclMain.c. -if {[catch {package require tcltest 2.0.2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } namespace eval ::tcl::test::main { diff --git a/tests/mathop.test b/tests/mathop.test index 703a572..f4a810f 100644 --- a/tests/mathop.test +++ b/tests/mathop.test @@ -11,7 +11,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/misc.test b/tests/misc.test index 0d93ea6..8f8516e 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -13,7 +13,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/msgcat.test b/tests/msgcat.test index 4ab3622..6e95c03 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -12,10 +12,9 @@ # Note that after running these tests, entries will be left behind in the # message catalogs for locales foo, foo_BAR, and foo_BAR_baz. -package require Tcl 8.5- -if {[catch {package require tcltest 2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } if {[catch {package require msgcat 1.6}]} { puts stderr "Skipping tests in [info script]. No msgcat 1.6 found to test." diff --git a/tests/namespace-old.test b/tests/namespace-old.test index 1d6a805..f503a4d 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-old.test @@ -15,7 +15,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/namespace.test b/tests/namespace.test index ad24fce..8209cf3 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -12,8 +12,10 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} testConstraint memory [llength [info commands memory]] ::tcltest::loadTestedCommands @@ -179,21 +181,21 @@ test namespace-7.6 {recursive Tcl_DeleteNamespace, no active call frames in ns} namespace delete test_ns_2 } {} test namespace-7.7 {Bug 1655305} -setup { - interp create slave + interp create child # Can't invoke through the ensemble, since deleting the global namespace # (indirectly, via deleting ::tcl) deletes the ensemble. - slave eval {rename ::tcl::info::commands ::infocommands} - slave hide infocommands - slave eval { + child eval {rename ::tcl::info::commands ::infocommands} + child hide infocommands + child eval { proc foo {} { namespace delete :: } } } -body { - slave eval foo - slave invokehidden infocommands + child eval foo + child invokehidden infocommands } -cleanup { - interp delete slave + interp delete child } -result {} test namespace-7.8 {Bug ba1419303b4c} -setup { @@ -269,28 +271,28 @@ test namespace-8.4 {TclTeardownNamespace, cmds imported from deleted ns go away} [info commands test_ns_import::*] } [list [lsort {::test_ns_import::p ::test_ns_import::cmd1 ::test_ns_import::cmd2}] {} ::test_ns_import::p] test namespace-8.5 {TclTeardownNamespace: preserve errorInfo; errorCode values} { - interp create slave - slave eval {trace add execution error leave {namespace delete :: ;#}} - catch {slave eval error foo bar baz} - interp delete slave + interp create child + child eval {trace add execution error leave {namespace delete :: ;#}} + catch {child eval error foo bar baz} + interp delete child set ::errorInfo } {bar invoked from within -"slave eval error foo bar baz"} +"child eval error foo bar baz"} test namespace-8.6 {TclTeardownNamespace: preserve errorInfo; errorCode values} { - interp create slave - slave eval {trace add variable errorCode write {namespace delete :: ;#}} - catch {slave eval error foo bar baz} - interp delete slave + interp create child + child eval {trace add variable errorCode write {namespace delete :: ;#}} + catch {child eval error foo bar baz} + interp delete child set ::errorInfo } {bar invoked from within -"slave eval error foo bar baz"} +"child eval error foo bar baz"} test namespace-8.7 {TclTeardownNamespace: preserve errorInfo; errorCode values} { - interp create slave - slave eval {trace add execution error leave {namespace delete :: ;#}} - catch {slave eval error foo bar baz} - interp delete slave + interp create child + child eval {trace add execution error leave {namespace delete :: ;#}} + catch {child eval error foo bar baz} + interp delete child set ::errorCode } baz @@ -2797,9 +2799,9 @@ test namespace-51.15 {namespace resolution path control} -body { namespace delete ::test_ns_2 } test namespace-51.16 {Bug 1566526} { - interp create slave - slave eval namespace eval demo namespace path :: - interp delete slave + interp create child + child eval namespace eval demo namespace path :: + interp delete child } {} test namespace-51.17 {resolution epoch handling: Bug 2898722} -setup { set result {} @@ -3000,19 +3002,19 @@ test namespace-52.11 {unknown: with TCL_EVAL_INVOKE} -setup { } } catch {rename ::noSuchCommand {}} - set ::slave [interp create] + set ::child [interp create] } -body { - $::slave alias bar noSuchCommand + $::child alias bar noSuchCommand namespace eval test_ns_1 { namespace unknown unknown proc unknown args { return FAIL } - $::slave eval bar + $::child eval bar } } -cleanup { - interp delete $::slave - unset ::slave + interp delete $::child + unset ::child namespace delete test_ns_1 rename ::unknown {} rename unknown.save ::unknown @@ -3373,7 +3375,7 @@ test namespace-57.0 { rename ns2::p2 {} return $res } -cleanup { - unset res + unset res namespace delete ns2 namespace delete ns3 } -result success diff --git a/tests/notify.test b/tests/notify.test index e34392b..7375f83 100644 --- a/tests/notify.test +++ b/tests/notify.test @@ -14,7 +14,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/nre.test b/tests/nre.test index 5591862..7cf06d1 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -10,7 +10,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/obj.test b/tests/obj.test index 62bcae5..e10cebf 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -34,7 +34,7 @@ test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} tes string } { set first [string first $t [testobj types]] - set r [expr {$r && ($first != -1)}] + set r [expr {$r && ($first >= 0)}] } set result $r } {1} diff --git a/tests/oo.test b/tests/oo.test index c73c36c..0dc26f2 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -8,8 +8,8 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require TclOO 1.0.3 -package require tcltest 2 -if {"::tcltest" in [namespace children]} { +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -304,19 +304,19 @@ test oo-1.18.2 {Bug 75b8433707: memory leak in oo-1.18} -setup { rename test-oo-1.18 {} } -result 0 test oo-1.18.3 {Bug 21c144f0f5} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { oo::define [oo::class create foo] superclass oo::class oo::class destroy } } -cleanup { - interp delete slave + interp delete child } test oo-1.18.4 {correct handling of cleanup in superclass set error} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { oo::class create A oo::class create B { superclass oo::class @@ -328,12 +328,12 @@ test oo-1.18.4 {correct handling of cleanup in superclass set error} -setup { [B create C] create d } } -returnCodes error -cleanup { - interp delete slave + interp delete child } -result {class should only be a direct superclass once} test oo-1.18.5 {correct handling of cleanup in superclass set error} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { oo::class create A oo::class create B { superclass oo::class @@ -345,7 +345,7 @@ test oo-1.18.5 {correct handling of cleanup in superclass set error} -setup { [B create C {B C}] create d } } -returnCodes error -cleanup { - interp delete slave + interp delete child } -result {attempt to form circular dependency graph} test oo-1.19 {basic test of OO functionality: teardown order} -body { oo::object create o @@ -1439,16 +1439,16 @@ test oo-7.8 {OO: next at the end of the method chain} -setup { } -result {foo2 foo 1 {no next method implementation}} test oo-7.9 {OO: defining inheritance in namespaces} -setup { set ::result {} - oo::class create ::master + oo::class create ::parent namespace eval ::foo { - oo::class create mixin {superclass ::master} + oo::class create mixin {superclass ::parent} } } -cleanup { - ::master destroy + ::parent destroy namespace delete ::foo } -body { namespace eval ::foo { - oo::class create bar {superclass master} + oo::class create bar {superclass parent} oo::class create boo oo::define boo {superclass bar} oo::define boo {mixin mixin} @@ -2135,18 +2135,18 @@ test oo-14.5 {OO and mixins and filters - advanced case} -setup { mix destroy } -result >>foobar<< test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create A { - superclass master + superclass parent method egg {} { return chicken } } oo::class create B { - superclass master + superclass parent mixin A method bar {} { # mixin from A @@ -2154,7 +2154,7 @@ test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup { } } oo::class create C { - superclass master + superclass parent mixin B method foo {} { # mixin from B @@ -2164,12 +2164,12 @@ test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup { [C new] foo } -result chicken test oo-14.7 {OO and filters from mixins of mixins} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create A { - superclass master + superclass parent method egg {} { return chicken } @@ -2180,7 +2180,7 @@ test oo-14.7 {OO and filters from mixins of mixins} -setup { } } oo::class create B { - superclass master + superclass parent mixin A filter f method bar {} { @@ -2189,7 +2189,7 @@ test oo-14.7 {OO and filters from mixins of mixins} -setup { } } oo::class create C { - superclass master + superclass parent mixin B filter f method foo {} { @@ -2201,18 +2201,18 @@ test oo-14.7 {OO and filters from mixins of mixins} -setup { } -result {(foo) (bar) (egg) chicken (egg) (bar) (foo)} test oo-14.8 {OO: class mixin order - Bug 1998221} -setup { set ::result {} - oo::class create master { + oo::class create parent { method test {} {} } } -cleanup { - master destroy + parent destroy } -body { oo::class create mix { - superclass master + superclass parent method test {} {lappend ::result mix; next; return $::result} } oo::class create cls { - superclass master + superclass parent mixin mix method test {} {lappend ::result cls; next; return $::result} } @@ -2915,13 +2915,13 @@ test oo-18.7 {OO: objdefine command support} -setup { invoked from within "oo::objdefine inst {rename ::inst ::INST;error foo}"}} test oo-18.8 {OO: define/self command support} -setup { - oo::class create master - oo::class create ::foo {superclass master} + oo::class create parent + oo::class create ::foo {superclass parent} } -body { catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {foobar while executing "error foobar" @@ -2932,15 +2932,15 @@ test oo-18.8 {OO: define/self command support} -setup { invoked from within "oo::define foo {rename ::foo ::bar; self {error foobar}}"} test oo-18.9 {OO: define/self command support} -setup { - oo::class create master + oo::class create parent set c [oo::class create now_this_is_a_very_very_long_class_name_indeed { - superclass master + superclass parent }] } -body { catch {oo::define $c {error err}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {err while executing "error err" @@ -2948,13 +2948,13 @@ test oo-18.9 {OO: define/self command support} -setup { invoked from within "oo::define $c {error err}"} test oo-18.10 {OO: define/self command support} -setup { - oo::class create master - oo::class create ::foo {superclass master} + oo::class create parent + oo::class create ::foo {superclass parent} } -body { catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {foobar while executing "error foobar" @@ -2965,13 +2965,13 @@ test oo-18.10 {OO: define/self command support} -setup { invoked from within "oo::define foo {self {rename ::foo {}; error foobar}}"} test oo-18.11 {OO: define/self command support} -setup { - oo::class create master - oo::class create ::foo {superclass master} + oo::class create parent + oo::class create ::foo {superclass parent} } -body { catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {this command cannot be called when the object has been deleted while executing "self {error foobar}" @@ -3594,12 +3594,12 @@ test oo-27.2 {variables declaration - object introspection} -setup { info object variables foo } -result {a b c} test oo-27.3 {variables declaration - basic behaviour} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} @@ -3609,13 +3609,13 @@ test oo-27.3 {variables declaration - basic behaviour} -setup { bar y } -result 3 test oo-27.4 {variables declaration - destructors too} -setup { - oo::class create master + oo::class create parent set result bad! } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} @@ -3640,12 +3640,12 @@ test oo-27.5 {variables declaration - object-bound variables} -setup { foo y } -result 2 test oo-27.6 {variables declaration - non-interference of levels} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} @@ -3660,12 +3660,12 @@ test oo-27.6 {variables declaration - non-interference of levels} -setup { list [bar y] [lsort [info object vars bar]] [bar eval {info vars *!}] } -result {{3 2 y! {}} {x! y!} {x! y!}} test oo-27.7 {variables declaration - one underlying variable space} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} @@ -3692,12 +3692,12 @@ test oo-27.9 {variables declaration - error cases - arrays} -body { oo::define oo::object variable bad(var) } -returnCodes error -result {invalid declared variable name "bad(var)": must not refer to an array element} test oo-27.10 {variables declaration - no instance var leaks with class resolvers} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable clsvar constructor {} { set clsvar 0 @@ -3720,12 +3720,12 @@ test oo-27.10 {variables declaration - no instance var leaks with class resolver list [inst1 value] [inst2 value] } -result {3 2} test oo-27.11 {variables declaration - no instance var leaks with class resolvers} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable clsvar constructor {} { set clsvar 0 @@ -3793,12 +3793,12 @@ test oo-27.13 {variables declaration: Bug 3185009: require refcount management} foo destroy } -result {0 7 1 7 {} 0 1 {can't read "x": no such variable}} test oo-27.14 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable y method boo {} { @@ -3809,12 +3809,12 @@ test oo-27.14 {variables declaration - multiple use} -setup { list [bar boo] [bar boo] } -result {1,1 2,2} test oo-27.15 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable variable x y method boo {} { @@ -3825,12 +3825,12 @@ test oo-27.15 {variables declaration - multiple use} -setup { list [bar boo] [bar boo] } -result {1,1 2,2} test oo-27.16 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable -clear variable y @@ -3842,12 +3842,12 @@ test oo-27.16 {variables declaration - multiple use} -setup { list [bar boo] [bar boo] } -result {1,1 1,2} test oo-27.17 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable -set y method boo {} { @@ -3858,12 +3858,12 @@ test oo-27.17 {variables declaration - multiple use} -setup { list [bar boo] [bar boo] } -result {1,1 1,2} test oo-27.18 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable -? y method boo {} { @@ -3961,12 +3961,12 @@ test oo-27.22 {variables declaration uniqueifies: Bug 3396896} -setup { } -result {v t} test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup { oo::class create Super - oo::class create Master { + oo::class create Parent { superclass Super variable member1 member2 constructor {} { - set member1 master1 - set member2 master2 + set member1 parent1 + set member2 parent2 } method getChild {} { Child new [self] @@ -3987,10 +3987,10 @@ test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup { method result {} {return $result} } } -body { - [[Master new] getChild] result + [[Parent new] getChild] result } -cleanup { Super destroy -} -result {master1 master2 master1 master2 master1 master2 master1 master2} +} -result {parent1 parent2 parent1 parent2 parent1 parent2 parent1 parent2} # A feature that's not supported because the mechanism may change without # warning, but is supposed to work... diff --git a/tests/ooNext2.test b/tests/ooNext2.test index 6a48d28..0ec7cdd 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -8,8 +8,8 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require TclOO 1.0.3 -package require tcltest 2 -if {"::tcltest" in [namespace children]} { +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -882,9 +882,9 @@ test oo-call-3.4 {current call introspection: in destructors} -setup { # caller set testopts { -setup { - oo::class create Master + oo::class create Parent oo::class create Foo { - superclass Master + superclass Parent method bar {} { puts abc tailcall puts hi @@ -892,11 +892,11 @@ set testopts { } } oo::class create Foo2 { - superclass Master + superclass Parent } } -cleanup { - Master destroy + Parent destroy } } diff --git a/tests/ooUtil.test b/tests/ooUtil.test index ff7093f..7fc9b9c 100644 --- a/tests/ooUtil.test +++ b/tests/ooUtil.test @@ -10,8 +10,8 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require TclOO 1.0.3 -package require tcltest 2 -if {"::tcltest" in [namespace children]} { +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -153,7 +153,7 @@ test ooUtil-1.8 {TIP 478: classmethod in child interp} -setup { oo::class create Table { superclass ActiveRecord } - # This is confirming that this is not the master interpreter + # This is confirming that this is not the parent interpreter list [Table find foo bar] [info globals childinterp] } } -cleanup { diff --git a/tests/opt.test b/tests/opt.test index a90e6b6..0af4488 100644 --- a/tests/opt.test +++ b/tests/opt.test @@ -12,12 +12,12 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } # the package we are going to test -package require opt 0.4.7 +package require opt 0.4.8 # we are using implementation specifics to test the package diff --git a/tests/package.test b/tests/package.test index e12dd30..1223d82 100644 --- a/tests/package.test +++ b/tests/package.test @@ -13,7 +13,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.3.3 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/parse.test b/tests/parse.test index 287c392..94c7f74 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -8,9 +8,9 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2.0.2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } namespace eval ::tcl::test::parse { @@ -405,14 +405,14 @@ test parse-8.11 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} testevalobjv { proc ::unknown args {lappend ::info [info level]; uplevel 1 foo} proc ::foo args {lappend ::info global} catch {rename ::noSuchCommand {}} - set ::slave [interp create] - $::slave alias bar noSuchCommand + set ::child [interp create] + $::child alias bar noSuchCommand set ::info {} namespace eval test_ns_1 { proc foo args {lappend ::info namespace} - $::slave eval bar - testevalobjv 1 [list $::slave eval bar] - uplevel #0 [list $::slave eval bar] + $::child eval bar + testevalobjv 1 [list $::child eval bar] + uplevel #0 [list $::child eval bar] } namespace delete test_ns_1 rename ::foo {} @@ -429,14 +429,14 @@ test parse-8.12 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} { lappend ::info ns }] catch {rename ::noSuchCommand {}} - set ::slave [interp create] - $::slave alias bar noSuchCommand + set ::child [interp create] + $::child alias bar noSuchCommand set ::info {} namespace eval test_ns_1 { - $::slave eval bar + $::child eval bar } namespace delete test_ns_1 - interp delete $::slave + interp delete $::child catch {rename ::noSuchCommand {}} set ::info } global diff --git a/tests/parseExpr.test b/tests/parseExpr.test index 8ca5fca..735dace 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -8,8 +8,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/parseOld.test b/tests/parseOld.test index 504d063..134a3c2 100644 --- a/tests/parseOld.test +++ b/tests/parseOld.test @@ -13,8 +13,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/pid.test b/tests/pid.test index 8887b66..47f753b 100644 --- a/tests/pid.test +++ b/tests/pid.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index 8ff806c..8121377 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -8,8 +8,10 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} set fullPkgPath [makeDirectory pkg] @@ -72,11 +74,11 @@ proc pkgtest::parseArgs { args } { # of the command line. proc pkgtest::parseIndex { filePath } { - # create a slave interpreter, where we override "package ifneeded" + # create a child interpreter, where we override "package ifneeded" - set slave [interp create] + set child [interp create] if {[catch { - $slave eval { + $child eval { rename package package_original proc package { args } { if {[lindex $args 0] eq "ifneeded"} { @@ -91,17 +93,17 @@ proc pkgtest::parseIndex { filePath } { } set dir [file dirname $filePath] - $slave eval {set curdir [pwd]} - $slave eval [list cd $dir] - $slave eval [list set dir $dir] - $slave eval [list source [file tail $filePath]] - $slave eval {cd $curdir} + $child eval {set curdir [pwd]} + $child eval [list cd $dir] + $child eval [list set dir $dir] + $child eval [list source [file tail $filePath]] + $child eval {cd $curdir} # Create the list in sorted order, so that we don't get spurious # errors because the order has changed. array set P {} - foreach {k v} [$slave eval {array get ::PKGS}] { + foreach {k v} [$child eval {array get ::PKGS}] { set P($k) $v } @@ -113,12 +115,12 @@ proc pkgtest::parseIndex { filePath } { set ei [dict get $opts -errorinfo] set ec [dict get $opts -errorcode] - catch {interp delete $slave} + catch {interp delete $child} error $ei $ec } - interp delete $slave + interp delete $child return $PKGS } diff --git a/tests/platform.test b/tests/platform.test index 53d534e..fff16fd 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +package require tcltest 2.5 namespace eval ::tcl::test::platform { namespace import ::tcltest::testConstraint diff --git a/tests/proc-old.test b/tests/proc-old.test index 96b24b8..79ee1fa 100644 --- a/tests/proc-old.test +++ b/tests/proc-old.test @@ -15,7 +15,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/proc.test b/tests/proc.test index 43d76d8..7039dbb 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -14,7 +14,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -389,9 +389,9 @@ test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} -body { test proc-7.4 {Proc struct outlives its interp: Bug 3532959} { set lambda x lappend lambda {set a 1} - interp create slave - slave eval [list apply $lambda foo] - interp delete slave + interp create child + child eval [list apply $lambda foo] + interp delete child unset lambda } {} diff --git a/tests/process.test b/tests/process.test index ef23cfb..d7f47b2 100644 --- a/tests/process.test +++ b/tests/process.test @@ -9,7 +9,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/pwd.test b/tests/pwd.test index d48c2ad..3486e70 100644 --- a/tests/pwd.test +++ b/tests/pwd.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/reg.test b/tests/reg.test index 2ee1048..847da32 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -10,7 +10,8 @@ # Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 + namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands @@ -287,7 +288,7 @@ namespace eval RETest { set infoflags [TestInfoFlags $flags] set ccmd [list testregexp -about {*}$f $re] set nsub [expr {[llength $args] - 1}] - if {$nsub == -1} { + if {$nsub < 0} { # didn't tell us number of subexps set ccmd "lreplace \[$ccmd\] 0 0" set info [list $infoflags] diff --git a/tests/regexp.test b/tests/regexp.test index bae1217..a2e6dbb 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -192,6 +192,17 @@ test regexp-3.7 {getting substrings back from regexp} { set foo 1; set f2 1; set f3 1; set f4 1 list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4 } {1 {1 2} {1 1} {-1 -1} {2 2}} +test regexp-3.8a {-indices by multi-byte utf-8} { + regexp -inline -indices {(\w+)-(\w+)} \ + "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442" +} {{0 10} {0 3} {5 10}} +test regexp-3.8b {-indices by multi-byte utf-8, from -start position} { + list\ + [regexp -inline -indices -start 3 {(\w+)-(\w+)} \ + "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"] \ + [regexp -inline -indices -start 4 {(\w+)-(\w+)} \ + "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"] +} {{{3 10} {3 3} {5 10}} {}} test regexp-4.1 {-nocase option to regexp} { regexp -nocase foo abcFOo diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 4d531bd..53a68c5 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/registry.test b/tests/registry.test index c5e6e5a..dbf4575 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -11,7 +11,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -24,6 +24,7 @@ if {[testConstraint win]} { testConstraint reg 1 } } +testConstraint notWine [expr {$::tcl_platform(platform) ne "windows" || ![info exists ::env(TRAVIS_OS_NAME)] || ![string match linux $::env(TRAVIS_OS_NAME)]}] # determine the current locale testConstraint english [expr { @@ -673,10 +674,10 @@ test registry-12.2 {BroadcastValue} -constraints {win reg} -body { test registry-12.3 {BroadcastValue} -constraints {win reg} -body { registry broadcast "" - 500 } -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\"" -test registry-12.4 {BroadcastValue} -constraints {win reg} -body { +test registry-12.4 {BroadcastValue} -constraints {win reg notWine} -body { registry broadcast {Environment} } -result {1 0} -test registry-12.5 {BroadcastValue} -constraints {win reg} -body { +test registry-12.5 {BroadcastValue} -constraints {win reg notWine} -body { registry b {} } -result {1 0} diff --git a/tests/rename.test b/tests/rename.test index 398d0f2..ddda909 100644 --- a/tests/rename.test +++ b/tests/rename.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/resolver.test b/tests/resolver.test index b0b395d..9916529 100644 --- a/tests/resolver.test +++ b/tests/resolver.test @@ -10,8 +10,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -if {"::tcltest" in [namespace children]} { +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -203,7 +203,7 @@ test resolver-2.1 {compiled var resolver: Bug #3383616} -setup { # resolver-agnostic). # # In order to make the test cases for the per-interpreter cmd literal pool -# reproducable and to minimize interactions between test cases, we use a slave +# reproducable and to minimize interactions between test cases, we use a child # interpreter per test-case. # # diff --git a/tests/result.test b/tests/result.test index 859e546..f1f5fb7 100644 --- a/tests/result.test +++ b/tests/result.test @@ -10,8 +10,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/safe-stock.test b/tests/safe-stock.test new file mode 100644 index 0000000..192189f --- /dev/null +++ b/tests/safe-stock.test @@ -0,0 +1,248 @@ +# safe-stock.test -- +# +# This file contains tests for safe Tcl that were previously in the file +# safe.test, and use files and packages of stock Tcl 8.7 to perform the tests. +# These files may be changed or disappear in future revisions of Tcl, for +# example package opt will eventually be removed. +# +# The tests are replaced in safe.tcl with tests that use files provided in the +# tests directory. Test numbering is for comparison with similar tests in +# safe.test. +# +# Sourcing this file into tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# The defunct package http 1.0 was convenient for testing package loading. +# - This file, safe-stock.test, uses packages opt and (from cookiejar) +# tcl::idna to provide alternative tests based on stock Tcl packages. +# - These are tests 7.1 7.2 7.4 9.11 9.13 +# - Tests 7.[124], 9.1[13] use "package require opt". +# - Tests 9.1[13] also use "package require tcl::idna". +# - The corresponding tests in safe.test use example packages provided in +# subdirectory auto0 of the tests directory, which are independent of any +# changes made to the packages provided with Tcl. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +foreach i [interp children] { + interp delete $i +} + +# When using package opt for testing positive/negative package search: +# - The directory location and the error message depend on whether +# and how the package is installed. + +# Error message for test 7.2 for "package require opt". +if {[string match *zipfs:/* [info library]]} { + # pkgIndex.tcl is in [info library] + # file to be sourced is in [info library]/opt* + set pkgOptErrMsg {permission denied} +} else { + # pkgIndex.tcl and file to be sourced are + # both in [info library]/opt* + set pkgOptErrMsg {can't find package opt} +} + +# Directory of opt for tests 7.4, 9.10, 9.12 for "package require opt". +if {[file exists [file join [info library] opt0.4]]} { + # Installed files in lib8.7/opt0.4 + set pkgOptDir opt0.4 +} elseif {[file exists [file join [info library] opt]]} { + # Installed files in zipfs, or source files used by "make test" + set pkgOptDir opt +} else { + error {cannot find opt library} +} + +# Directory of cookiejar for tests 9.10, 9.12 for "package require tcl::idna". +if {[file exists [file join [info library] cookiejar0.2]]} { + # Installed files in lib8.7/cookiejar0.2 + set pkgJarDir cookiejar0.2 +} elseif {[file exists [file join [info library] cookiejar]]} { + # Installed files in zipfs, or source files used by "make test" + set pkgJarDir cookiejar +} else { + error {cannot find cookiejar library} +} + +set SaveAutoPath $::auto_path +set ::auto_path [info library] +set TestsDir [file normalize [file dirname [info script]]] +set PathMapp {} +lappend PathMapp [file join [info library] $pkgOptDir] TCLLIB/OPTDIR +lappend PathMapp [file join [info library] $pkgJarDir] TCLLIB/JARDIR +lappend PathMapp $tcl_library TCLLIB $TestsDir TESTSDIR + +proc mapList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + return $listOut +} +proc mapAndSortList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + lsort $listOut +} + +# Force actual loading of the safe package because we use un-exported (and +# thus un-autoindexed) APIs in this test result arguments: +catch {safe::interpConfigure} + +# high level general test +test safe-stock-7.1 {tests that everything works at high level, uses pkg opt} -setup { + set i [safe::interpCreate] +} -body { + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a child works like in the parent) + set v [interp eval $i {package require opt}] + # no error shall occur: + interp eval $i {::tcl::Lempty {a list}} + set v +} -cleanup { + safe::interpDelete $i +} -match glob -result 0.4.* +test safe-stock-7.2 {tests specific path and interpFind/AddToAccessPath, uses pkg opt} -setup { +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # an error shall occur (opt is not anymore in the secure 0-level + # provided deep path) + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + list $token1 $token2 -- \ + [catch {interp eval $i {package require opt}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] +} -cleanup { +} -match glob -result "{\$p(:0:)} {\$p(:*:)} -- 1 {$pkgOptErrMsg} --\ + {TCLLIB */dummy/unixlike/test/path} -- {}" +test safe-stock-7.4 {tests specific path and positive search, uses pkg opt} -setup { +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i [file join [info library] $pkgOptDir]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # this time, unlike test safe-stock-7.2, opt should be found + list $token1 $token2 -- \ + [catch {interp eval $i {package require opt}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] + # Note that the glob match elides directories (those from the module path) + # other than the first and last in the access path. +} -cleanup { +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 0.4.* --\ + {TCLLIB * TCLLIB/OPTDIR} -- {}} + +# The following test checks whether the definition of tcl_endOfWord can be +# obtained from auto_loading. It was previously test "safe-5.1". +test safe-stock-9.8 {test auto-loading in safe interpreters, was safe-5.1} -setup { + catch {safe::interpDelete a} + safe::interpCreate a +} -body { + interp eval a {tcl_endOfWord "" 0} +} -cleanup { + safe::interpDelete a +} -result -1 +test safe-stock-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, uses pkg opt and tcl::idna} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $tcl_library $pkgOptDir] \ + [file join $tcl_library $pkgJarDir]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]] + set path2 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + # This has no effect because the records in Pkg of these directories were from access as children of {$p(:0:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $tcl_library $pkgJarDir] \ + [file join $tcl_library $pkgOptDir]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]] + set path4 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require tcl::idna}} msg3] + set code4 [catch {interp eval $i {package require opt}} msg4] + set code5 [catch {interp eval $i {::tcl::Lempty {a list}}} msg5] + set code6 [catch {interp eval $i {::tcl::idna::IDNAencode example.com}} 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:)} -- 0 1.* 0 0.4.* --\ + {TCLLIB TCLLIB/OPTDIR TCLLIB/JARDIR*} --\ + {TCLLIB TCLLIB/JARDIR TCLLIB/OPTDIR*} --\ + 0 0 0 example.com} +test safe-stock-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, uses pkg opt and tcl::idna} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $tcl_library $pkgOptDir] \ + [file join $tcl_library $pkgJarDir]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]] + set path2 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]} path5] + + # Try to load the packages. + set code3 [catch {interp eval $i {package require opt}} msg3] + set code6 [catch {interp eval $i {package require tcl::idna}} msg6] + + 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} --\ + 1 {* not found in access path} -- 1 1 --\ + {TCLLIB TCLLIB/OPTDIR TCLLIB/JARDIR*} -- {TCLLIB*}} + +set ::auto_path $SaveAutoPath +unset pkgOptErrMsg pkgOptDir pkgJarDir SaveAutoPath TestsDir PathMapp +rename mapList {} +rename mapAndSortList {} +# cleanup +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/safe-zipfs.test b/tests/safe-zipfs.test new file mode 100644 index 0000000..73703e4 --- /dev/null +++ b/tests/safe-zipfs.test @@ -0,0 +1,729 @@ +# safe-zipfs.test -- +# +# This file contains tests for safe Tcl that test its compatibility with the +# zipfs facilities introduced in Tcl 8.7. Test numbering is for comparison +# with similar tests in safe.test that do not use the zipfs file system. +# +# Sourcing this file into tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.5- + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +foreach i [interp children] { + interp delete $i +} + +set SaveAutoPath $::auto_path +set ::auto_path [info library] +set TestsDir [file normalize [file dirname [info script]]] + +set ZipMountPoint [zipfs root]auto-files +zipfs mount $ZipMountPoint [file join $TestsDir auto-files.zip] + +set PathMapp {} +lappend PathMapp $tcl_library TCLLIB $TestsDir TESTSDIR $ZipMountPoint ZIPDIR + +proc mapList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + return $listOut +} +proc mapAndSortList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + lsort $listOut +} + +# Force actual loading of the safe package because we use un-exported (and +# thus un-autoindexed) APIs in this test result arguments: +catch {safe::interpConfigure} + +# testing that nested and statics do what is advertised (we use a static +# package - Tcltest - but it might be absent if we're in standard tclsh) + +testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}] + +# Tests 5.* test the example files before using them to test safe interpreters. + +test safe-zipfs-5.1 {example tclIndex commands, test in parent interpreter; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {0 ok1 0 ok2} +test safe-zipfs-5.2 {example tclIndex commands, negative test in parent interpreter; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} +test safe-zipfs-5.3 {example pkgIndex.tcl packages, test in parent interpreter, child directories; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + 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 + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} +test safe-zipfs-5.4 {example pkgIndex.tcl packages, test in parent interpreter, main directories; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + 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 + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} +test safe-zipfs-5.5 {example modules packages, test in parent interpreter, replace path; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + 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 $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + 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-zipfs-5.6 {example modules packages, test in parent interpreter, append to path; zipfs} -setup { + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + 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 $ZipMountPoint auto0 modules] + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} + +# high level general test +# Use zipped example packages not http1.0 etc +test safe-zipfs-7.1 {tests that everything works at high level; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0] + set i [safe::interpCreate] + set ::auto_path $tmpAutoPath +} -body { + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a child works like in the parent) + set v [interp eval $i {package require SafeTestPackage1}] + # no error shall occur: + interp eval $i {HeresPackage1} + set v +} -cleanup { + safe::interpDelete $i +} -match glob -result 1.2.3 +test safe-zipfs-7.2 {tests specific path and interpFind/AddToAccessPath; zipfs} -setup { +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # should add as p* (not p2 if parent has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level + # provided deep path) + list $token1 $token2 $token3 -- \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] +} -cleanup { +} -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\ + 1 {can't find package SafeTestPackage1} --\ + {TCLLIB */dummy/unixlike/test/path ZIPDIR/auto0} -- {}} +test safe-zipfs-7.4 {tests specific path and positive search; zipfs} -setup { +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # this time, unlike test safe-zipfs-7.2, SafeTestPackage1 should be found + list $token1 $token2 -- \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] + # Note that the glob match elides directories (those from the module path) + # other than the first and last in the access path. +} -cleanup { +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\ + {TCLLIB * ZIPDIR/auto0/auto1} -- {}} + +test safe-zipfs-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset); zipfs} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Load and run the commands. + # This guarantees the test will pass even if the tokens are swapped. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -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-zipfs-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset); zipfs} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Do not load the commands. With the tokens swapped, the test + # will pass only if the Safe Base has called auto_reset. + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load and run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -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-zipfs-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement; zipfs} -setup { +} -body { + # For complete correspondence to safe-stock87-9.11, include auto0 in access path. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0] \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}. + # This would have no effect because the records in Pkg of these directories + # were from access as children of {$p(:1:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0] \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + 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 +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\ + {TCLLIB ZIPDIR/auto0 ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ + {TCLLIB ZIPDIR/auto0 ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} +test safe-zipfs-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0; zipfs} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + 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 +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ + 0 1.2.3 0 2.3.4 --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ + {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} +test safe-zipfs-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed; zipfs} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]} path5] + + # Try to load the packages. + 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 +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ + 1 {* not found in access path} -- 1 1 --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} -- {TCLLIB*}} +test safe-zipfs-9.20 {check module loading; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} -- res0 res1 res2} +# - The command safe::InterpSetConfig adds the parent's [tcl::tm::list] in +# tokenized form to the child's access path, and then adds all the +# descendants, discovered recursively by using glob. +# - The order of the directories in the list returned by glob is system-dependent, +# and therefore this is true also for (a) the order of token assignment to +# descendants of the [tcl::tm::list] roots; and (b) the order of those same +# directories in the access path. Both those things must be sorted before +# comparing with expected results. The test is therefore not totally strict, +# but will notice missing or surplus directories. +test safe-zipfs-9.21 {interpConfigure change the access path; check module loading; stale data case 1; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Load pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + 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 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ + ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-zipfs-9.20. +test safe-zipfs-9.22 {interpConfigure change the access path; check module loading; stale data case 0; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + 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 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ + ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-zipfs-9.20. +test safe-zipfs-9.23 {interpConfigure change the access path; check module loading; stale data case 3; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Refresh stale pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + 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 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ + ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-zipfs-9.20. +test safe-zipfs-9.24 {interpConfigure change the access path; check module loading; stale data case 2 (worst case); zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + 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 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ + ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-zipfs-9.20. + +# cleanup +set ::auto_path $SaveAutoPath +zipfs unmount ${ZipMountPoint} +unset SaveAutoPath TestsDir ZipMountPoint PathMapp +rename mapList {} +rename mapAndSortList {} +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/safe.test b/tests/safe.test index 79aa9ab..1177e19 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -4,27 +4,52 @@ # using safe interpreters. Sourcing this file into tcl runs the tests and # generates output for errors. No output means no errors were found. # +# The defunct package http 1.0 was convenient for testing package loading. +# - Tests that used http are replaced here with tests that use example packages +# provided in subdirectory auto0 of the tests directory, which are independent +# of any changes made to the packages provided with Tcl itself. +# - These are tests 7.1 7.2 7.4 9.11 9.13 +# - Tests 5.* test the example packages themselves before they +# are used to test Safe Base interpreters. +# - Alternative tests using stock packages of Tcl 8.7 are in file +# safe-stock.test. +# # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.5- - if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } -foreach i [interp slaves] { +foreach i [interp children] { 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] + +proc mapList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + return $listOut +} +proc mapAndSortList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + lsort $listOut +} -# Force actual loading of the safe package because we use un exported (and +# Force actual loading of the safe package because we use un-exported (and # thus un-autoindexed) APIs in this test result arguments: catch {safe::interpConfigure} @@ -35,16 +60,16 @@ testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}] test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body { safe::interpConfigure -} -result {no value given for parameter "slave" (use -help for full usage) : - slave name () name of the slave} +} -result {no value given for parameter "child" (use -help for full usage) : + child name () name of the child} test safe-1.2 {safe::interpCreate syntax} -returnCodes error -body { safe::interpCreate -help } -result {Usage information: Var/FlagName Type Value Help ------------ ---- ----- ---- (-help gives this help) - ?slave? name () name of the slave (optional) - -accessPath list () access path for the slave + ?child? name () name of the child (optional) + -accessPath list () access path for the child -noStatics boolflag (false) prevent loading of statically linked pkgs -statics boolean (true) loading of statically linked pkgs -nestedLoadOk boolflag (false) allow nested loading @@ -53,7 +78,7 @@ test safe-1.2 {safe::interpCreate syntax} -returnCodes error -body { test safe-1.3 {safe::interpInit syntax} -returnCodes error -body { safe::interpInit -noStatics } -result {bad value "-noStatics" for parameter - slave name () name of the slave} + child name () name of the child} test safe-2.1 {creating interpreters, should have no aliases} emptyTest { # Disabled this test. It tests nothing sensible. [Bug 999612] @@ -66,6 +91,8 @@ test safe-2.2 {creating interpreters, should have no aliases} -setup { a aliases } -cleanup { safe::interpDelete a + # This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters + # is regrettable and should be removed at the next major revision. } -result "" test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -setup { catch {safe::interpDelete a} @@ -115,6 +142,8 @@ test safe-4.1 {safe::interpDelete} -setup { } -body { interp create a safe::interpDelete a + # This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters + # is regrettable and should be removed at the next major revision. } -result "" test safe-4.2 {safe::interpDelete, indirectly} -setup { catch {safe::interpDelete a} @@ -122,6 +151,8 @@ test safe-4.2 {safe::interpDelete, indirectly} -setup { interp create a a alias exit safe::interpDelete a a eval exit + # This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters + # is regrettable and should be removed at the next major revision. } -result "" test safe-4.5 {safe::interpDelete} -setup { catch {safe::interpDelete a} @@ -138,17 +169,118 @@ test safe-4.6 {safe::interpDelete, indirectly} -setup { a eval exit } -result "" -# The following test checks whether the definition of tcl_endOfWord can be -# obtained from auto_loading. +# The old test "safe-5.1" has been moved to "safe-stock-9.8". +# A replacement test using example files is "safe-9.8". +# Tests 5.* test the example files before using them to test safe interpreters. -test safe-5.1 {test auto-loading in safe interpreters} -setup { - catch {safe::interpDelete a} - safe::interpCreate a +test safe-5.1 {example tclIndex commands, test in parent interpreter} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0 auto1] [file join $TestsDir auto0 auto2] } -body { - interp eval a {tcl_endOfWord "" 0} + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 } -cleanup { - safe::interpDelete a -} -result -1 + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {0 ok1 0 ok2} +test safe-5.2 {example tclIndex commands, negative test in parent interpreter} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} +test safe-5.3 {example pkgIndex.tcl packages, test in parent interpreter, child directories} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + 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 + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} +test safe-5.4 {example pkgIndex.tcl packages, test in parent interpreter, main directories} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + 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 + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} +test safe-5.5 {example modules packages, test in parent interpreter, replace path} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + 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] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + 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-5.6 {example modules packages, test in parent interpreter, append to path} -setup { + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + 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] + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + 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 interps 'information leak' proc SafeEval {script} { @@ -176,59 +308,121 @@ 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... # high level general test -test safe-7.1 {tests that everything works at high level} -body { +# Use example packages not http1.0 etc +test safe-7.1 {tests that everything works at high level} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] set i [safe::interpCreate] + set ::auto_path $tmpAutoPath +} -body { # no error shall occur: # (because the default access_path shall include 1st level sub dirs so - # package require in a slave works like in the master) - set v [interp eval $i {package require http 2}] + # package require in a child works like in the parent) + set v [interp eval $i {package require SafeTestPackage1}] # no error shall occur: - interp eval $i {http::config} - safe::interpDelete $i + interp eval $i {HeresPackage1} set v -} -match glob -result 2.* -test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body { +} -cleanup { + safe::interpDelete $i +} -match glob -result 1.2.3 +test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -setup { +} -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] - # should add as p1 + # should add as p* (not p1 if parent has a module path) set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] - # an error shall occur (http is not anymore in the secure 0-level + # should add as p* (not p2 if parent has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level # provided deep path) - list $token1 $token2 \ - [catch {interp eval $i {package require http 1}} msg] $msg \ - [safe::interpConfigure $i]\ - [safe::interpDelete $i] -} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" + list $token1 $token2 $token3 -- \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] +} -cleanup { +} -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\ + 1 {can't find package SafeTestPackage1} --\ + {TCLLIB */dummy/unixlike/test/path TESTSDIR/auto0} -- {}} test safe-7.3 {check that safe subinterpreters work} { + set g [interp children] + if {$g ne {}} { + append g { -- residue of an earlier test} + } + set h [info vars ::safe::S*] + if {$h ne {}} { + append h { -- residue of an earlier test} + } set i [safe::interpCreate] set j [safe::interpCreate [list $i x]] - list [interp eval $j {join {o k} ""}] [safe::interpDelete $i] [interp exists $j] -} {ok {} 0} + list $g $h [interp eval $j {join {o k} ""}] [safe::interpDelete $i] \ + [interp exists $j] [info vars ::safe::S*] +} {{} {} ok {} 0 {}} +test safe-7.3.1 {check that safe subinterpreters work with namespace names} -setup { +} -body { + set g [interp children] + if {$g ne {}} { + append g { -- residue of an earlier test} + } + set h [info vars ::safe::S*] + if {$h ne {}} { + append h { -- residue of an earlier test} + } + set i [safe::interpCreate foo::bar] + set j [safe::interpCreate [list $i hello::world]] + list $g $h [interp eval $j {join {o k} ""}] \ + [foo::bar eval {hello::world eval {join {o k} ""}}] \ + [safe::interpDelete $i] \ + [interp exists $j] [info vars ::safe::S*] +} -match glob -result {{} {} ok ok {} 0 {}} +test safe-7.4 {tests specific path and positive search} -setup { +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # this time, unlike test safe-7.2, SafeTestPackage1 should be found + list $token1 $token2 -- \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] + # Note that the glob match elides directories (those from the module path) + # other than the first and last in the access path. +} -cleanup { +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\ + {TCLLIB * TESTSDIR/auto0/auto1} -- {}} # 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} @@ -239,10 +433,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 -} -result {1 {permission denied} {{ERROR for slave a : ".": is a directory}}} + rename safe-test-log {} + unset i log +} -result {1 {permission denied} {{ERROR for child 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} @@ -253,10 +449,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 -} -result {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}}} + rename safe-test-log {} + unset i log +} -result {1 {permission denied} {{ERROR for child 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} @@ -271,10 +469,12 @@ test safe-8.5 {safe source control on file} -setup { } msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i -} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"]] + rename safe-test-log {} + unset i log +} -result [list 1 {no such file or directory} [list "ERROR for child 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} @@ -287,10 +487,12 @@ test safe-8.6 {safe source control on file} -setup { } msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i -} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"]] + rename safe-test-log {} + unset i log +} -result [list 1 {no such file or directory} [list "ERROR for child 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} @@ -305,14 +507,16 @@ test safe-8.7 {safe source control on file} -setup { } msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i -} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]] + rename safe-test-log {} + unset i log +} -result [list 1 {no such file or directory} [list "ERROR for child 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 { @@ -322,8 +526,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 { @@ -336,10 +542,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 { @@ -352,8 +559,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 {} @@ -374,8 +585,10 @@ test safe-9.2 {safe interps' error in deleteHook} -setup { list [safe::interpDelete $i] $res $log } -cleanup { safe::setLogCmd $prevlog - unset log -} -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}}} + catch {rename testDelHook {}} + rename safe-test-log {} + unset i log res +} -result {{} {arg1 arg2 a} {{NOTICE for child a : About to delete} {ERROR for child a : Delete hook error (being catched)} {NOTICE for child a : Deleted}}} test safe-9.3 {dual specification of statics} -returnCodes error -body { safe::interpCreate -stat true -nostat } -result {conflicting values given for -statics and -noStatics} @@ -403,7 +616,546 @@ 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}] + safe::interpConfigure $i -accessPath /foo/bar + set a [safe::interpConfigure $i] + set b [safe::interpConfigure $i -aCCess] + set c [safe::interpConfigure $i -nested] + set d [safe::interpConfigure $i -statics] + set e [safe::interpConfigure $i -DEL] + safe::interpConfigure $i -accessPath /blah -statics 1 + set f [safe::interpConfigure $i] + safe::interpConfigure $i -deleteHook toto -nosta -nested 0 + set g [safe::interpConfigure $i] + + list $a $b $c $d $e $f $g +} -cleanup { + safe::interpDelete $i + 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 {test autoloading commands indexed in tclIndex files} -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]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load and run the commands. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + list $path1 $path2 -- $code1 $msg1 $code2 $msg2 -- $mappA +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*}} +test safe-9.9 {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 \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Load and run the commands. + # This guarantees the test will pass even if the tokens are swapped. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + 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]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -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.10 {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 \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Do not load the commands. With the tokens swapped, the test + # will pass only if the Safe Base has called auto_reset. + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + 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]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load and run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -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.11 {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. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [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]] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}. + # This would have no effect because the records in Pkg of these directories + # were from access as children of {$p(:1:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [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]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + 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 +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\ + {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.12 {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]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + 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]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + 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 +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ + 0 1.2.3 0 2.3.4 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} +test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed} -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]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]} path5] + + # Try to load the packages. + 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 +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ + 1 {* not found in access path} -- 1 1 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} -- {TCLLIB*}} +test safe-9.20 {check module loading} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} -- res0 res1 res2} +# - The command safe::InterpSetConfig adds the parent's [tcl::tm::list] in +# tokenized form to the child's access path, and then adds all the +# descendants, discovered recursively by using glob. +# - The order of the directories in the list returned by glob is system-dependent, +# and therefore this is true also for (a) the order of token assignment to +# descendants of the [tcl::tm::list] roots; and (b) the order of those same +# directories in the access path. Both those things must be sorted before +# comparing with expected results. The test is therefore not totally strict, +# but will notice missing or surplus directories. +test safe-9.21 {interpConfigure change the access path; check module loading; stale data case 1} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + 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]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Load pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + 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 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. +test safe-9.22 {interpConfigure change the access path; check module loading; stale data case 0} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + 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]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + 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 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. +test safe-9.23 {interpConfigure change the access path; check module loading; stale data case 3} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + 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]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Refresh stale pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + 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 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. +test safe-9.24 {interpConfigure change the access path; check module loading; stale data case 2 (worst case)} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + 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]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + 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 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. catch {teststaticpkg Safepkg1 0 0} test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { @@ -412,7 +1164,7 @@ test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { interp eval $i {load {} Safepkg1} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup { set i [safe::interpCreate] } -body { @@ -421,7 +1173,7 @@ test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup { } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure +} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure invoked from within "load {} Safepkg1" invoked from within @@ -444,7 +1196,7 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints Tcl interp eval $i {interp create x; load {} Safepkg1 x} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { set i [safe::interpCreate -nestedloadok] catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o @@ -452,7 +1204,7 @@ test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints T } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure +} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure invoked from within "load {} Safepkg1 x" invoked from within @@ -608,6 +1360,15 @@ proc buildEnvironment {filename} { set testdir2 [makeDirectory deletemetoo $testdir] set testfile [makeFile {} $filename $testdir2] } +proc buildEnvironment2 {filename} { + upvar 1 testdir testdir testdir2 testdir2 testfile testfile + upvar 1 testdir3 testdir3 testfile2 testfile2 + set testdir [makeDirectory deletethisdir] + set testdir2 [makeDirectory deletemetoo $testdir] + set testfile [makeFile {} $filename $testdir2] + set testdir3 [makeDirectory deleteme $testdir] + set testfile2 [makeFile {} $filename $testdir3] +} #### New tests for Safe base glob, with patches @ Bug 2964715 test safe-13.1 {glob is restricted [Bug 2964715]} -setup { set i [safe::interpCreate] @@ -679,21 +1440,33 @@ test safe-13.6 {as 13.4 but test silent failure when result is outside access_pa safe::interpDelete $i removeDirectory $testdir } -result {} -test safe-13.7 {mimic the glob call by tclPkgUnknown which gives a deliberate error in a safe interpreter [Bug 2964715]} -setup { +test safe-13.7 {mimic the glob call by tclPkgUnknown in a safe interpreter [Bug 2964715]} -setup { set i [safe::interpCreate] buildEnvironment pkgIndex.tcl } -body { set safeTD [::safe::interpAddToAccessPath $i $testdir] ::safe::interpAddToAccessPath $i $testdir2 - string map [list $safeTD EXPECTED] [$i eval [list \ + mapList [list $safeTD EXPECTED] [$i eval [list \ + glob -directory $safeTD -join * pkgIndex.tcl]] +} -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {EXPECTED/deletemetoo/pkgIndex.tcl} +test safe-13.7.1 {mimic the glob call by tclPkgUnknown in a safe interpreter with multiple subdirectories} -setup { + set i [safe::interpCreate] + buildEnvironment2 pkgIndex.tcl +} -body { + set safeTD [::safe::interpAddToAccessPath $i $testdir] + ::safe::interpAddToAccessPath $i $testdir2 + ::safe::interpAddToAccessPath $i $testdir3 + mapAndSortList [list $safeTD EXPECTED] [$i eval [list \ glob -directory $safeTD -join * pkgIndex.tcl]] } -cleanup { safe::interpDelete $i removeDirectory $testdir -} -result {{EXPECTED/deletemetoo/pkgIndex.tcl}} -# Note the extra {} around the result above; that's *expected* because of the -# format of virtual path roots. -test safe-13.8 {mimic the glob call by tclPkgUnknown without the deliberate error that is specific to pkgIndex.tcl [Bug 2964715]} -setup { +} -result {EXPECTED/deleteme/pkgIndex.tcl EXPECTED/deletemetoo/pkgIndex.tcl} +# See comments on lsort after test safe-9.20. +test safe-13.8 {mimic the glob call by tclPkgUnknown without the special treatment that is specific to pkgIndex.tcl [Bug 2964715]} -setup { set i [safe::interpCreate] buildEnvironment notIndex.tcl } -body { @@ -731,9 +1504,10 @@ test safe-13.10 {as 13.8 but test silent failure when result is outside access_p removeDirectory $testdir } -result {} rename buildEnvironment {} +rename buildEnvironment2 {} #### Test for the module path -test safe-14.1 {Check that module path is the same as in the master interpreter [Bug 2964715]} -setup { +test safe-14.1 {Check that module path is the same as in the parent interpreter [Bug 2964715]} -setup { set i [safe::interpCreate] } -body { set tm {} @@ -795,6 +1569,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] @@ -804,6 +1579,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] @@ -818,6 +1594,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] @@ -827,9 +1604,58 @@ 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 # cleanup +set ::auto_path $SaveAutoPath +unset SaveAutoPath TestsDir PathMapp +rename mapList {} +rename mapAndSortList {} ::tcltest::cleanupTests return diff --git a/tests/scan.test b/tests/scan.test index eaeaa49..fe912db 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/security.test b/tests/security.test index eeabc9c..3235a1f 100644 --- a/tests/security.test +++ b/tests/security.test @@ -11,7 +11,7 @@ # All rights reserved. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/set-old.test b/tests/set-old.test index e098d66..e29b93b 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -14,7 +14,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/set.test b/tests/set.test index 2efa268..303c2d7 100644 --- a/tests/set.test +++ b/tests/set.test @@ -11,7 +11,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/socket.test b/tests/socket.test index 1c1a89d..6a045b1 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -61,7 +61,7 @@ # using the remote server are not performed. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -72,6 +72,7 @@ catch [list package require -exact Tcltest [info patchlevel]] if {[expr {[info exists ::env(TRAVIS_OSX_IMAGE)] && [string match xcode* $::env(TRAVIS_OSX_IMAGE)]}]} { return } +testConstraint notWine [expr {$::tcl_platform(platform) ne "windows" || ![info exists ::env(TRAVIS_OS_NAME)] || ![string match linux $::env(TRAVIS_OS_NAME)]}] # Some tests require the Thread package or exec command testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] @@ -248,7 +249,7 @@ if {$doTestsWithRemoteServer} { # Some tests are run only if we are doing testing against a remote server. testConstraint doTestsWithRemoteServer $doTestsWithRemoteServer if {!$doTestsWithRemoteServer} { - if {[string first s $::tcltest::verbose] != -1} { + if {[string first s $::tcltest::verbose] >= 0} { puts "Skipping tests with remote server. See tests/socket.test for" puts "information on how to run remote server." puts "Reason for not doing remote tests: $noRemoteTestReason" @@ -291,6 +292,9 @@ proc getPort sock { lindex [fconfigure $sock -sockname] 2 } +# Some tests in this file are known to hang *occasionally* on OSX; stop the +# worst offenders. +testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] # ---------------------------------------------------------------------- @@ -731,7 +735,7 @@ test socket_$af-2.12 {} [list socket stdio supported_$af] { close $f set ::done } 0 -test socket_$af-2.13 {Bug 1758a0b603} {socket stdio} { +test socket_$af-2.13 {Bug 1758a0b603} {socket stdio notWine} { file delete $path(script) set f [open $path(script) w] puts $f { @@ -1540,7 +1544,7 @@ test socket_$af-11.11 {testing spurious events} -setup { after cancel $timer sendCommand {close $server} } -result {0 2690 1} -test socket_$af-11.12 {testing EOF stickyness} -constraints [list socket supported_$af doTestsWithRemoteServer] -setup { +test socket_$af-11.12 {testing EOF stickyness} -constraints [list socket supported_$af doTestsWithRemoteServer notWine] -setup { set counter 0 set done 0 set port [sendCommand { @@ -1864,12 +1868,12 @@ proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} { } } tcltest::DebugPuts 1 "== test \[$::localhost\]:$port $testmode ==" - set ::master [thread::id] - # helper thread creating async connection and initiating transfer (detach) to master: + set ::parent [thread::id] + # helper thread creating async connection and initiating transfer (detach) to parent: set ::helper [thread::create] thread::send -async $::helper [list \ - lassign [list $::master $::localhost $port $testmode] \ - ::master ::localhost ::port ::testmode + lassign [list $::parent $::localhost $port $testmode] \ + ::parent ::localhost ::port ::testmode ] thread::send -async $::helper { set ::helper [thread::id] @@ -1878,29 +1882,29 @@ proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} { if {"helper-writable" in $::testmode} {;# to test both sides during connect fileevent $fd writable [list apply {{fd} { if {[thread::id] ne $::helper} { - thread::send -async $::master {set ::count "ERROR: invalid thread, $::helper is expecting"} + thread::send -async $::parent {set ::count "ERROR: invalid thread, $::helper is expecting"} close $fd return } }} $fd] };# thread::detach $fd - thread::send -async $::master [list transf_master $fd {*}$args] + thread::send -async $::parent [list transf_parent $fd {*}$args] } iteration first } - # master proc commiting transfer attempt (attach) and checking acquire was successful: - proc transf_master {fd args} { + # parent proc commiting transfer attempt (attach) and checking acquire was successful: + proc transf_parent {fd args} { tcltest::DebugPuts 1 "** trma / $::count ** $args **" thread::attach $fd - if {"master-close" in $::testmode} {;# to test close during connect + if {"parent-close" in $::testmode} {;# to test close during connect set ::count $::count close $fd return };# fileevent $fd writable [list apply {{fd} { - if {[thread::id] ne $::master} { - thread::send -async $::master {set ::count "ERROR: invalid thread, $::master is expecting"} + if {[thread::id] ne $::parent} { + thread::send -async $::parent {set ::count "ERROR: invalid thread, $::parent is expecting"} close $fd return } @@ -1928,7 +1932,7 @@ proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} { if {$srvsock ne {}} {close $srvsock} if {[info exists ::helper]} {thread::release -wait $::helper} tcltest::DebugPuts 1 "== stop / $::count ==" - unset -nocomplain ::count ::testmode ::master ::helper + unset -nocomplain ::count ::testmode ::parent ::helper } } test socket_$af-13.2.tr1 {Testing socket transfer between threads during async connect} -body { @@ -1938,12 +1942,12 @@ test socket_$af-13.2.tr2 {Testing socket transfer between threads during async c transf_test {transfer helper-writable} 100 } -result 100 -constraints [list socket supported_$af thread] test socket_$af-13.2.cl1 {Testing socket transfer between threads during async connect} -body { - transf_test {master-close} 100 + transf_test {parent-close} 100 } -result 100 -constraints [list socket supported_$af thread] test socket_$af-13.2.cl2 {Testing socket transfer between threads during async connect} -body { - transf_test {master-close helper-writable} 100 + transf_test {parent-close helper-writable} 100 } -result 100 -constraints [list socket supported_$af thread] -catch {rename transf_master {}} +catch {rename transf_parent {}} rename transf_test {} # ---------------------------------------------------------------------- @@ -2098,7 +2102,7 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ } -result {{} bye} # FIXME: we should also have an IPv6 counterpart of this test socket-14.5 {[socket -async] which fails before any connect() can be made} \ - -constraints {socket supported_inet} \ + -constraints {socket supported_inet notWine} \ -body { # address from rfc5737 socket -async -myaddr 192.0.2.42 127.0.0.1 [randport] @@ -2433,7 +2437,7 @@ test socket-14.12 {[socket -async] background progress triggered by [fconfigure } -result {connection refused} test socket-14.13 {testing writable event when quick failure} \ - -constraints {socket win supported_inet} \ + -constraints {socket win supported_inet notWine} \ -body { # Test for bug 336441ed59 where a quick background fail was ignored @@ -2517,7 +2521,7 @@ test socket-14.18 {bug c6ed4acfd8: running async socket connect made other conne } -result {} test socket-14.19 {tip 456 -- introduce the -reuseport option} \ - -constraints {socket} \ + -constraints {socket notWine} \ -body { proc accept {channel address port} {} set port [randport] diff --git a/tests/split.test b/tests/split.test index 3ca328b..9c95b81 100644 --- a/tests/split.test +++ b/tests/split.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/stack.test b/tests/stack.test index 4c50f74..77cb69f 100644 --- a/tests/stack.test +++ b/tests/stack.test @@ -9,8 +9,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} # Note that a failure in this test may result in a crash of the executable. diff --git a/tests/string.test b/tests/string.test index e42da8e..4a8746d 100644 --- a/tests/string.test +++ b/tests/string.test @@ -13,7 +13,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -131,11 +131,11 @@ test string-2.11.3.$noComp {string compare, unicode} { run {string compare \334\334\334\374\374 \334\334\334\334\334} } 1 test string-2.12.$noComp {string compare, high bit} { - # This test will fail if the underlying comparaison + # This test will fail if the underlying comparison # is using signed chars instead of unsigned chars. # (like SunOS's default memcmp thus the compat/memcmp.c) run {string compare "\x80" "@"} - # Nb this tests works also in utf8 space because \x80 is + # Nb this tests works also in utf-8 space because \x80 is # translated into a 2 or more bytelength but whose first byte has # the high bit set. } 1 @@ -1506,6 +1506,20 @@ test string-12.22.$noComp {string range, shimmering binary/index} { test string-12.23.$noComp {string range, surrogates, bug [11ae2be95dac9417]} utf16 { run {list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]} } [list \U100000 {} b] +test string-12.24.$noComp {bignum index arithmetic} -setup { + proc demo {i j} {string range fubar $i $j} +} -cleanup { + rename demo {} +} -body { + demo 2 0+0x10000000000000000 +} -result bar +test string-12.25.$noComp {bignum index arithmetic} -setup { + proc demo {i j} {string range fubar $i $j} +} -cleanup { + rename demo {} +} -body { + demo 0x10000000000000000-0xffffffffffffffff 3 +} -result uba test string-13.1.$noComp {string repeat} { list [catch {run {string repeat}} msg] $msg @@ -1651,6 +1665,9 @@ test stringComp-14.24.$noComp {Bug 1af8de570511} { test stringComp-14.25.$noComp {} { string length [string replace [string repeat a\xFE 2] 3 end {}] } 3 +test stringComp-14.26.$noComp {} { + run {string replace abcd 0x10000000000000000-0xffffffffffffffff 2 e} +} aed test string-15.1.$noComp {string tolower too few args} { list [catch {run {string tolower}} msg] $msg @@ -2298,7 +2315,7 @@ test string-28.12.$noComp {tcl::prefix longest} { tcl::prefix longest {apa {} appa} {} } {} test string-28.13.$noComp {tcl::prefix longest} { - # Test UTF8 handling + # Test utf-8 handling tcl::prefix longest {ax\x90 bep ax\x91} a } ax diff --git a/tests/stringObj.test b/tests/stringObj.test index 85aff72..ca6c323 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -13,7 +13,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -29,8 +29,8 @@ testConstraint nodep [info exists tcl_precision] test stringObj-1.1 {string type registration} testobj { set t [testobj types] set first [string first "string" $t] - set result [expr {$first != -1}] -} {1} + set result [expr {$first >= 0}] +} 1 test stringObj-2.1 {Tcl_NewStringObj} testobj { set result "" diff --git a/tests/subst.test b/tests/subst.test index 0d0614d..42d1bec 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands @@ -282,18 +282,18 @@ test subst-13.1 {Bug 3081065} -setup { demo name2 } subst13.tcl] } -body { - interp create slave - slave eval [list source $script] - interp delete slave - interp create slave - slave eval { + interp create child + child eval [list source $script] + interp delete child + interp create child + child eval { set count 400 while {[incr count -1]} { lappend bloat [expr {rand()}] } } - slave eval [list source $script] - interp delete slave + child eval [list source $script] + interp delete child } -cleanup { removeFile subst13.tcl } diff --git a/tests/switch.test b/tests/switch.test index 4d204bb..8ca049c 100644 --- a/tests/switch.test +++ b/tests/switch.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/tailcall.test b/tests/tailcall.test index a7829b0..3704333 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -10,7 +10,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/tcltest.test b/tests/tcltest.test index c856209..b2debe7 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -13,13 +13,13 @@ # testing to run the test itself. Ditto on things like [verbose]. # # It would be better to have the -body of the tests run the tcltest -# commands in a slave interp so the [test] being tested would not +# commands in a child interp so the [test] being tested would not # interfere with the [test] doing the testing. # -if {[catch {package require tcltest 2.1}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.1 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } namespace eval ::tcltest::test { @@ -27,7 +27,7 @@ namespace eval ::tcltest::test { namespace import ::tcltest::* makeFile { - package require tcltest + package require tcltest 2.5 namespace import ::tcltest::test test a-1.0 {test a} { list 0 @@ -63,11 +63,11 @@ test tcltest-1.3 {tcltest -h} {exec} { } {1 0} # -verbose, implicit & explicit testing of [verbose] -proc slave {msgVar args} { +proc child {msgVar args} { upvar 1 $msgVar msg interp create [namespace current]::i - # Fake the slave interp into dumping output to a file + # Fake the child interp into dumping output to a file i eval {namespace eval ::tcltest {}} i eval "set tcltest::outputChannel\ \[[list open [set of [makeFile {} output]] w]]" @@ -99,44 +99,44 @@ proc slave {msgVar args} { return $code } test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrWin} { - set result [slave msg test.tcl] + set result [child msg test.tcl] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 0 0 1} test tcltest-2.1 {tcltest -verbose 'b'} {unixOrWin} { - set result [slave msg test.tcl -verbose 'b'] + set result [child msg test.tcl -verbose 'b'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 0 0 1} test tcltest-2.2 {tcltest -verbose 'p'} {unixOrWin} { - set result [slave msg test.tcl -verbose 'p'] + set result [child msg test.tcl -verbose 'p'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 1 0 1} test tcltest-2.3 {tcltest -verbose 's'} {unixOrWin} { - set result [slave msg test.tcl -verbose 's'] + set result [child msg test.tcl -verbose 's'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 0 1 1} test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrWin} { - set result [slave msg test.tcl -verbose 'ps'] + set result [child msg test.tcl -verbose 'ps'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 1 1 1} test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrWin} { - set result [slave msg test.tcl -verbose 'psb'] + set result [child msg test.tcl -verbose 'psb'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 1 1 1} test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrWin} { - set result [slave msg test.tcl -verbose "pass skip body"] + set result [child msg test.tcl -verbose "pass skip body"] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] @@ -145,7 +145,7 @@ test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrWin} { test tcltest-2.6 {tcltest -verbose 't'} { -constraints {unixOrWin} -body { - set result [slave msg test.tcl -verbose 't'] + set result [child msg test.tcl -verbose 't'] list $result $msg } -result {^0 .*a-1.0 start.*b-1.0 start} @@ -155,7 +155,7 @@ test tcltest-2.6 {tcltest -verbose 't'} { test tcltest-2.6a {tcltest -verbose 'start'} { -constraints {unixOrWin} -body { - set result [slave msg test.tcl -verbose start] + set result [child msg test.tcl -verbose start] list $result $msg } -result {^0 .*a-1.0 start.*b-1.0 start} @@ -178,7 +178,7 @@ test tcltest-2.7 {tcltest::verbose} { test tcltest-2.8 {tcltest -verbose 'error'} { -constraints {unixOrWin} -body { - set result [slave msg test.tcl -verbose error] + set result [child msg test.tcl -verbose error] list $result $msg } -result {errorInfo: foo.*errorCode: 9} @@ -186,22 +186,22 @@ test tcltest-2.8 {tcltest -verbose 'error'} { } # -match, [match] test tcltest-3.1 {tcltest -match 'a*'} {unixOrWin} { - set result [slave msg test.tcl -match a* -verbose 'ps'] + set result [child msg test.tcl -match a* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 1 0 0 1} test tcltest-3.2 {tcltest -match 'b*'} {unixOrWin} { - set result [slave msg test.tcl -match b* -verbose 'ps'] + set result [child msg test.tcl -match b* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg] } {0 0 1 0 1} test tcltest-3.3 {tcltest -match 'c*'} {unixOrWin} { - set result [slave msg test.tcl -match c* -verbose 'ps'] + set result [child msg test.tcl -match c* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg] } {0 0 0 1 1} test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrWin} { - set result [slave msg test.tcl -match {a* b*} -verbose 'ps'] + set result [child msg test.tcl -match {a* b*} -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg] } {0 1 1 0 1} @@ -221,27 +221,27 @@ test tcltest-3.5 {tcltest::match} { # -skip, [skip] test tcltest-4.1 {tcltest -skip 'a*'} {unixOrWin} { - set result [slave msg test.tcl -skip a* -verbose 'ps'] + set result [child msg test.tcl -skip a* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg] } {0 0 1 1 1} test tcltest-4.2 {tcltest -skip 'b*'} {unixOrWin} { - set result [slave msg test.tcl -skip b* -verbose 'ps'] + set result [child msg test.tcl -skip b* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg] } {0 1 0 1 1} test tcltest-4.3 {tcltest -skip 'c*'} {unixOrWin} { - set result [slave msg test.tcl -skip c* -verbose 'ps'] + set result [child msg test.tcl -skip c* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 1 0 1} test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrWin} { - set result [slave msg test.tcl -skip {a* b*} -verbose 'ps'] + set result [child msg test.tcl -skip {a* b*} -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg] } {0 0 0 1 1} test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrWin} { - set result [slave msg test.tcl -match {a* b*} -skip b* -verbose 'ps'] + set result [child msg test.tcl -match {a* b*} -skip b* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 1 0 0 1} @@ -262,12 +262,12 @@ test tcltest-4.6 {tcltest::skip} { # -constraints, -limitconstraints, [testConstraint], # $constraintsSpecified, [limitConstraints] test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrWin} { - set result [slave msg test.tcl -constraints knownBug -verbose 'ps'] + set result [child msg test.tcl -constraints knownBug -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg] } {0 1 1 1 1} test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrWin} { - set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1] + set result [child msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 0 0 1 1} @@ -340,7 +340,7 @@ test tcltest-5.5 {InitConstraints: list of built-in constraints} \ # -outfile, -errfile, [outputChannel], [outputFile], [errorChannel], [errorFile] set printerror [makeFile { - package require tcltest + package require tcltest 2.5 namespace import ::tcltest::* puts [outputChannel] "a test" ::tcltest::PrintError "a really short string" @@ -357,28 +357,28 @@ set printerror [makeFile { test tcltest-6.1 {tcltest -outfile, -errfile defaults} { -constraints unixOrWin -body { - slave msg $printerror + child msg $printerror return $msg } -result {a test.*a really} -match regexp } test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrWin unixExecs} { - slave msg $printerror -outfile a.tmp + child msg $printerror -outfile a.tmp set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" a.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ $result1 $result2 [file exists a.tmp] [file delete a.tmp] } {0 1 0 1 1 {}} test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrWin unixExecs} { - slave msg $printerror -errfile a.tmp + child msg $printerror -errfile a.tmp set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" a.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ $result1 $result2 [file exists a.tmp] [file delete a.tmp] } {1 0 1 0 1 {}} test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrWin unixExecs} { - slave msg $printerror -outfile a.tmp -errfile b.tmp + child msg $printerror -outfile a.tmp -errfile b.tmp set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" b.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ @@ -463,7 +463,7 @@ test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} { # -debug, [debug] # Must use child processes to test -debug because it always writes # messages to stdout, and we have no way to capture stdout of a -# slave interp +# child interp test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrWin} { catch {exec [interpreter] test.tcl -debug 0} msg regexp "Flags passed into tcltest" $msg @@ -510,7 +510,7 @@ removeFile test.tcl # directory tests set a [makeFile { - package require tcltest + package require tcltest 2.5 tcltest::makeFile {} a.tmp puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]" exit @@ -525,7 +525,7 @@ normalizePath normaldirectory test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrWin -setup { file delete -force thisdirectorydoesnotexist } -body { - slave msg $a -tmpdir thisdirectorydoesnotexist + child msg $a -tmpdir thisdirectorydoesnotexist file exists [file join thisdirectorydoesnotexist a.tmp] } -cleanup { file delete -force thisdirectorydoesnotexist @@ -533,7 +533,7 @@ test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrWin -setup { test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} { -constraints unixOrWin -body { - slave msg $a -tmpdir $tdiaf + child msg $a -tmpdir $tdiaf return $msg } -result {*not a directory*} @@ -558,7 +558,7 @@ switch -- $::tcl_platform(platform) { test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} { -constraints {unix notRoot} -body { - slave msg $a -tmpdir $notReadableDir + child msg $a -tmpdir $notReadableDir return $msg } -result {*not readable*} @@ -574,7 +574,7 @@ testConstraint notFAT [expr { test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} { -constraints {unixOrWin notRoot notFAT} -body { - slave msg $a -tmpdir $notWriteableDir + child msg $a -tmpdir $notWriteableDir return $msg } -result {*not writeable*} @@ -583,7 +583,7 @@ test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} { test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} { -constraints unixOrWin -body { - slave msg $a -tmpdir $normaldirectory + child msg $a -tmpdir $normaldirectory # The join is necessary because the message can be split on multiple # lines file exists [file join $normaldirectory a.tmp] @@ -629,7 +629,7 @@ test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} { file delete -force thisdirectorydoesnotexist } -body { - slave msg $a -testdir thisdirectorydoesnotexist + child msg $a -testdir thisdirectorydoesnotexist return $msg } -match glob @@ -638,7 +638,7 @@ test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} { test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} { -constraints unixOrWin -body { - slave msg $a -testdir $tdiaf + child msg $a -testdir $tdiaf return $msg } -match glob @@ -647,7 +647,7 @@ test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} { test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} { -constraints {unix notRoot} -body { - slave msg $a -testdir $notReadableDir + child msg $a -testdir $notReadableDir return $msg } -match glob @@ -656,7 +656,7 @@ test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} { test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} { -constraints unixOrWin -body { - slave msg $a -testdir $normaldirectory + child msg $a -testdir $normaldirectory # The join is necessary because the message can be split on multiple # lines list [string first "testdir: $normaldirectory" [join $msg]] \ @@ -735,7 +735,7 @@ test tcltest-9.1 {-file d*.tcl} -constraints {unixOrWin} -setup { set old [testsDirectory] testsDirectory [file dirname [info script]] } -body { - slave msg [file join [testsDirectory] all.tcl] -file d*.test + child msg [file join [testsDirectory] all.tcl] -file d*.test return $msg } -cleanup { testsDirectory $old @@ -745,7 +745,7 @@ test tcltest-9.2 {-file d*.tcl} -constraints {unixOrWin} -setup { set old [testsDirectory] testsDirectory [file dirname [info script]] } -body { - slave msg [file join [testsDirectory] all.tcl] \ + child msg [file join [testsDirectory] all.tcl] \ -file d*.test -notfile dstring* regexp {dstring\.test} $msg } -cleanup { @@ -784,7 +784,7 @@ test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup { makeFile {} fee $d file copy [file join [file dirname [info script]] all.tcl] $d } -body { - slave msg [file join [temporaryDirectory] all.tcl] -file f* + child msg [file join [temporaryDirectory] all.tcl] -file f* regexp {exiting with errors:} $msg } -cleanup { file delete [file join $d all.tcl] @@ -795,7 +795,7 @@ test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup { # -preservecore, [preserveCore] set mc [makeFile { - package require tcltest + package require tcltest 2.5 namespace import ::tcltest::test test makecore {make a core file} { set f [open core w] @@ -807,23 +807,23 @@ set mc [makeFile { cd [temporaryDirectory] test tcltest-10.1 {-preservecore 0} {unixOrWin} { - slave msg $mc -preservecore 0 + child msg $mc -preservecore 0 file delete core regexp "Core file produced" $msg } {0} test tcltest-10.2 {-preservecore 1} {unixOrWin} { - slave msg $mc -preservecore 1 + child msg $mc -preservecore 1 file delete core regexp "Core file produced" $msg } {1} test tcltest-10.3 {-preservecore 2} {unixOrWin} { - slave msg $mc -preservecore 2 + child msg $mc -preservecore 2 file delete core list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \ [regexp "core-" $msg] [file delete core-makecore] } {1 1 1 {}} test tcltest-10.4 {-preservecore 3} {unixOrWin} { - slave msg $mc -preservecore 3 + child msg $mc -preservecore 3 file delete core list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \ [regexp "core-" $msg] [file delete core-makecore] @@ -846,7 +846,7 @@ removeFile makecore.tcl # -load, -loadfile, [loadScript], [loadFile] set contents { - package require tcltest + package require tcltest 2.5 namespace import tcltest::* puts [outputChannel] $::tcltest::loadScript exit @@ -854,7 +854,7 @@ set contents { set loadfile [makeFile $contents load.tcl] test tcltest-12.1 {-load xxx} {unixOrWin} { - slave msg $loadfile -load xxx + child msg $loadfile -load xxx return $msg } {xxx} @@ -942,7 +942,7 @@ makeFile { } single2.test $spd set allfile [makeFile { - package require tcltest + package require tcltest 2.5 namespace import tcltest::* testsDirectory [file join [temporaryDirectory] singleprocdir] runAllTests @@ -952,7 +952,7 @@ cd [workingDirectory] test tcltest-14.1 {-singleproc - single process} { -constraints {unixOrWin} -body { - slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory] + child msg $allfile -singleproc 0 -tmpdir [temporaryDirectory] return $msg } -result {Test file error: can't unset .foo.: no such variable} @@ -962,7 +962,7 @@ test tcltest-14.1 {-singleproc - single process} { test tcltest-14.2 {-singleproc - multiple process} { -constraints {unixOrWin} -body { - slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory] + child msg $allfile -singleproc 1 -tmpdir [temporaryDirectory] return $msg } -result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0} @@ -999,25 +999,25 @@ set dtd1 [makeDirectory dirtestdir2.1 $dtd] set dtd2 [makeDirectory dirtestdir2.2 $dtd] set dtd3 [makeDirectory dirtestdir2.3 $dtd] makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir] runAllTests } all.tcl $dtd makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.1] runAllTests } all.tcl $dtd1 makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.2] runAllTests } all.tcl $dtd2 makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3] runAllTests @@ -1026,7 +1026,7 @@ makeFile { test tcltest-15.1 {basic directory walking} { -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -tmpdir [temporaryDirectory]] == 1} { error $msg @@ -1040,7 +1040,7 @@ test tcltest-15.1 {basic directory walking} { test tcltest-15.2 {-asidefromdir} { -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -asidefromdir dirtestdir2.3 \ -tmpdir [temporaryDirectory]] == 1} { @@ -1058,7 +1058,7 @@ Error: No test files remain after applying your match and skip patterns!$} test tcltest-15.3 {-relateddir, non-existent dir} { -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -relateddir [file join [temporaryDirectory] dirtestdir0] \ -tmpdir [temporaryDirectory]] == 1} { @@ -1073,7 +1073,7 @@ test tcltest-15.3 {-relateddir, non-existent dir} { test tcltest-15.4 {-relateddir, subdir} { -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} { error $msg @@ -1086,7 +1086,7 @@ test tcltest-15.4 {-relateddir, subdir} { test tcltest-15.5 {-relateddir, -asidefromdir} { -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -relateddir "dirtestdir2.1 dirtestdir2.2" \ -asidefromdir dirtestdir2.2 \ @@ -1147,25 +1147,25 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { # set this to { } instead of just {} to get around quirk in # Windows env handling that removes empty elements from env array. set ::env(TCLTEST_OPTIONS) { } - interp create slave1 - slave1 eval [list set argv {-debug 2}] - slave1 alias puts puts - interp create slave2 - slave2 alias puts puts + interp create child1 + child1 eval [list set argv {-debug 2}] + child1 alias puts puts + interp create child2 + child2 alias puts puts } -cleanup { - interp delete slave2 - interp delete slave1 + interp delete child2 + interp delete child1 if {$oldoptions eq "none"} { unset ::env(TCLTEST_OPTIONS) } else { set ::env(TCLTEST_OPTIONS) $oldoptions } } -body { - slave1 eval [package ifneeded tcltest [package provide tcltest]] - slave1 eval tcltest::debug + child1 eval [package ifneeded tcltest [package provide tcltest]] + child1 eval tcltest::debug set ::env(TCLTEST_OPTIONS) "-debug 3" - slave2 eval [package ifneeded tcltest [package provide tcltest]] - slave2 eval tcltest::debug + child2 eval [package ifneeded tcltest [package provide tcltest]] + child2 eval tcltest::debug } -result {^3$} -match regexp -output\ {tcltest::debug\s+= 2.*tcltest::debug\s+= 3} @@ -1174,7 +1174,7 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { cd [temporaryDirectory] # PrintError test tcltest-20.1 {PrintError} {unixOrWin} { - set result [slave msg $printerror] + set result [child msg $printerror] list $result [regexp "Error: a really short string" $msg] \ [regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \ [regexp " \"Really" $msg] [regexp Problem $msg] @@ -1385,7 +1385,7 @@ test tcltest-21.12 { set atd [makeDirectory alltestdir] makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] alltestdir] runAllTests @@ -1397,7 +1397,7 @@ makeFile { error "throw an error" } error.test $atd makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* test foo-1.1 {foo} { -body { return 1 } @@ -1407,7 +1407,7 @@ makeFile { } test.test $atd # Must use a child process because stdout/stderr parsing can't be -# duplicated in slave interp. +# duplicated in child interp. test tcltest-22.1 {runAllTests} { -constraints {unixOrWin} -body { @@ -1796,7 +1796,7 @@ test tcltest-25.3 { test tcltest-26.1 {Bug/RFE 1017151} -setup { makeFile { - package require tcltest + package require tcltest 2.5 set ::errorInfo "Should never see this" tcltest::test tcltest-26.1.0 { no errorInfo when only return code mismatch @@ -1806,7 +1806,7 @@ test tcltest-26.1 {Bug/RFE 1017151} -setup { tcltest::cleanupTests } test.tcl } -body { - slave msg [file join [temporaryDirectory] test.tcl] + child msg [file join [temporaryDirectory] test.tcl] return $msg } -cleanup { removeFile test.tcl @@ -1816,7 +1816,7 @@ test tcltest-26.1 {Bug/RFE 1017151} -setup { test tcltest-26.2 {Bug/RFE 1017151} -setup { makeFile { - package require tcltest + package require tcltest 2.5 set ::errorInfo "Should never see this" tcltest::test tcltest-26.2.0 {do not mask body errorInfo} -body { error "body error" @@ -1826,7 +1826,7 @@ test tcltest-26.2 {Bug/RFE 1017151} -setup { tcltest::cleanupTests } test.tcl } -body { - slave msg [file join [temporaryDirectory] test.tcl] + child msg [file join [temporaryDirectory] test.tcl] return $msg } -cleanup { removeFile test.tcl diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index b0aa054..193ba0a 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -1,6 +1,6 @@ #! /usr/bin/env tclsh -package require tcltest 2.2 +package require tcltest 2.5 namespace import ::tcltest::* testConstraint exec [llength [info commands exec]] testConstraint fcopy [llength [info commands fcopy]] diff --git a/tests/thread.test b/tests/thread.test index 2524911..0a35d1b 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -39,11 +39,11 @@ set threadSuperKillScript { proc getThreadErrorFromInfo { info } { set list [split $info \n] set idx [lsearch -glob $list "*eval*unwound*"] - if {$idx != -1} then { + if {$idx >= 0} then { return [lindex $list $idx] } set idx [lsearch -glob $list "*eval*canceled*"] - if {$idx != -1} then { + if {$idx >= 0} then { return [lindex $list $idx] } return ""; # some other error we do not care about. @@ -805,7 +805,7 @@ test thread-7.21 {cancel: subst -unwind} -constraints {thread drainEventQueue} - } -cleanup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -result {{} 1 1 {eval unwound}} -test thread-7.22 {cancel: slave interp} -constraints {thread drainEventQueue} -setup { +test thread-7.22 {cancel: child interp} -constraints {thread drainEventQueue} -setup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -body { set serverthread [thread::create -joinable \ @@ -835,7 +835,7 @@ test thread-7.22 {cancel: slave interp} -constraints {thread drainEventQueue} -s } -cleanup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -result {{} 1 1 {eval canceled}} -test thread-7.23 {cancel: slave interp -unwind} -constraints {thread drainEventQueue} -setup { +test thread-7.23 {cancel: child interp -unwind} -constraints {thread drainEventQueue} -setup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -body { set serverthread [thread::create -joinable \ diff --git a/tests/timer.test b/tests/timer.test index 5e729ef..48d88b6 100644 --- a/tests/timer.test +++ b/tests/timer.test @@ -14,7 +14,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -568,15 +568,15 @@ test timer-9.1 {AfterCleanupProc procedure} -setup { } -result {before after2 after4} test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup { - interp create slave - slave eval namespace export after - slave eval namespace eval foo namespace import ::after + interp create child + child eval namespace export after + child eval namespace eval foo namespace import ::after } -body { - slave eval foo::after 1 - slave eval namespace origin foo::after + child eval foo::after 1 + child eval namespace origin foo::after } -cleanup { # Bug will cause crash here; would cause failure otherwise - interp delete slave + interp delete child } -result ::after test timer-11.1 {Bug 1350291: [after] overflowing 32-bit field} -body { diff --git a/tests/tm.test b/tests/tm.test index 001b73e..65629ad 100644 --- a/tests/tm.test +++ b/tests/tm.test @@ -6,9 +6,8 @@ # Copyright (c) 2004 by Donal K. Fellows. # All rights reserved. -package require Tcl 8.5- if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/trace.test b/tests/trace.test index 1099f48..3703216 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -11,8 +11,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -2197,11 +2199,11 @@ foo {if {[catch {bar}]} { }} 2 error leavestep foo foo 0 error leave}} -test trace-28.4 {exec traces in slave with 'return -code error'} { - interp create slave - interp alias slave traceExecute {} traceExecute +test trace-28.4 {exec traces in child with 'return -code error'} { + interp create child + interp alias child traceExecute {} traceExecute set info {} - set res [interp eval slave { + set res [interp eval child { set info {} set res {} @@ -2229,7 +2231,7 @@ test trace-28.4 {exec traces in slave with 'return -code error'} { list $res }] - interp delete slave + interp delete child lappend res [join $info \n] } {{error error} {foo foo enter foo {if {[catch {bar}]} { diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index 21c8230..1ecaeef 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -10,7 +10,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/unixFile.test b/tests/unixFile.test index 4dd9920..492e5d0 100644 --- a/tests/unixFile.test +++ b/tests/unixFile.test @@ -10,7 +10,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test index d7b86fd..5233496 100644 --- a/tests/unixForkEvent.test +++ b/tests/unixForkEvent.test @@ -8,8 +8,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} testConstraint testfork [llength [info commands testfork]] diff --git a/tests/unixInit.test b/tests/unixInit.test index ab00b4e..26d4130 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -10,8 +10,10 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2.2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} unset -nocomplain path catch {set oldlang $env(LANG)} set env(LANG) C diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test index 0cf7e1e..cdf0519 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -11,7 +11,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/unknown.test b/tests/unknown.test index 6c31c3d..4cad132 100644 --- a/tests/unknown.test +++ b/tests/unknown.test @@ -11,8 +11,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} unset -nocomplain x catch {rename unknown unknown.old} diff --git a/tests/unload.test b/tests/unload.test index b669f9b..815ff31 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -156,14 +156,14 @@ test unload-3.3 {unloading of a package that has never been loaded from a safe i unload [file join $testDir pkga$ext] {} child } -result {file "*" has never been loaded in this interpreter} test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for package name} -setup { - if {[lsearch -index 1 [info loaded child] Pkgb] == -1} { + if {[lsearch -index 1 [info loaded child] Pkgb] < 0} { load [file join $testDir pkgb$ext] pKgB child } } -constraints [list $dll $loaded] -returnCodes error -match glob -body { unload [file join $testDir pkgb$ext] {} child } -result {file "*" cannot be unloaded under a safe interpreter} test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for package name} -setup { - if {[lsearch -index 1 [info loaded child] Pkgua] == -1} { + if {[lsearch -index 1 [info loaded child] Pkgua] < 0} { load [file join $testDir pkgua$ext] pkgua child } } -constraints [list $dll $loaded] -body { diff --git a/tests/uplevel.test b/tests/uplevel.test index b197587..4ee6a34 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -304,7 +304,24 @@ test uplevel-7.3 {var access, LVT in upper level} -setup { rename foo {} rename moo {} } -result {3 3 3} + + +test uplevel-8.0 { + string representation isn't generated when there is only one argument +} -body { + set res {} + set script [list lindex 5] + lappend res [apply {script { + uplevel $script + }} $script] + lappend res [string match {value is a list *no string representation*} [ + ::tcl::unsupported::representation $script]] +} -cleanup { + unset script + unset res +} -result {5 1} + # cleanup ::tcltest::cleanupTests return diff --git a/tests/upvar.test b/tests/upvar.test index 29e3ed2..9e44a79 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -12,7 +12,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/utf.test b/tests/utf.test index 51ea2e5..935830c 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -9,7 +9,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/util.test b/tests/util.test index b516a0e..d8e5507 100644 --- a/tests/util.test +++ b/tests/util.test @@ -8,7 +8,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -476,7 +476,7 @@ test util-7.4 {TclPrecTraceProc - write traces, bogus values} -constraints preci } -result {1 {can't set "tcl_precision": improper value for precision} 12} # This test always succeeded in the C locale anyway... -test util-8.1 {TclNeedSpace - correct UTF8 handling} { +test util-8.1 {TclNeedSpace - correct utf-8 handling} { # Bug 411825 # Note that this test relies on the fact that # [interp target] calls on Tcl_AppendElement() @@ -490,7 +490,7 @@ test util-8.1 {TclNeedSpace - correct UTF8 handling} { interp delete \u5420 set result } "\u5420 foo" -test util-8.2 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.2 {TclNeedSpace - correct utf-8 handling} testdstring { # Bug 411825 # This tests the same bug as the previous test, but # should be more future-proof, as the DString @@ -500,14 +500,14 @@ test util-8.2 {TclNeedSpace - correct UTF8 handling} testdstring { testdstring element foo llength [testdstring get] } 2 -test util-8.3 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.3 {TclNeedSpace - correct utf-8 handling} testdstring { # Bug 411825 - new variant reported by Dossy Shiobara testdstring free testdstring append \u00A0 -1 testdstring element foo llength [testdstring get] } 2 -test util-8.4 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.4 {TclNeedSpace - correct utf-8 handling} testdstring { # Another bug uncovered while fixing 411825 testdstring free testdstring append {\ } -1 @@ -515,13 +515,13 @@ test util-8.4 {TclNeedSpace - correct UTF8 handling} testdstring { testdstring element foo llength [testdstring get] } 2 -test util-8.5 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.5 {TclNeedSpace - correct utf-8 handling} testdstring { testdstring free testdstring append {\\ } -1 testdstring element foo list [llength [testdstring get]] [string length [testdstring get]] } {2 6} -test util-8.6 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.6 {TclNeedSpace - correct utf-8 handling} testdstring { testdstring free testdstring append {\\ } -1 testdstring append \{ -1 @@ -818,6 +818,9 @@ test util-9.57 {Tcl_GetIntForIndex} { test util-9.58 {Tcl_GetIntForIndex} -body { string index abcd end--0x8000000000000000 } -result {} +test util-9.59 {Tcl_GetIntForIndex} { + string index abcd 0-0x10000000000000000 +} {} test util-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x0000000000000000 diff --git a/tests/var.test b/tests/var.test index a5b91f8..72873b7 100644 --- a/tests/var.test +++ b/tests/var.test @@ -15,7 +15,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -1040,15 +1040,15 @@ test var-22.0 {leak in array element unset: Bug a3309d01db} -setup { } -result 0 test var-22.1 {leak in localVarName intrep: Bug 80304238ac} -setup { proc doit {} { - interp create slave - slave eval { + interp create child + child eval { proc doit script { eval $script set foo bar } doit {foreach foo baz {}} } - interp delete slave + interp delete child } } -constraints memory -body { set end [getbytes] diff --git a/tests/while-old.test b/tests/while-old.test index a15ada2..eddc025 100644 --- a/tests/while-old.test +++ b/tests/while-old.test @@ -14,7 +14,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/while.test b/tests/while.test index 642ec93..30aff4b 100644 --- a/tests/while.test +++ b/tests/while.test @@ -11,7 +11,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/winConsole.test b/tests/winConsole.test index 1e00428..9075ff3 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -10,7 +10,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/winDde.test b/tests/winDde.test index acba304..78a36f8 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -10,8 +10,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 - #tcltest::configure -verbose {pass start} + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -25,6 +24,7 @@ if {[testConstraint win]} { testConstraint dde 1 } } +testConstraint notWine [expr {$::tcl_platform(platform) ne "windows" || ![info exists ::env(TRAVIS_OS_NAME)] || ![string match linux $::env(TRAVIS_OS_NAME)]}] # ------------------------------------------------------------------------- @@ -43,7 +43,7 @@ proc createChildProcess {ddeServerName args} { # DDE child server - # if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -154,15 +154,15 @@ test winDde-3.5 {DDE request locally} -constraints dde -body { dde request -binary TclEval self \xe1 } -result "foo\x00" # Set variable a to A with diaeresis (unicode C4) by relying on the fact -# that utf8 is sent (e.g. "c3 84" on the wire) -test winDde-3.6 {DDE request utf8} -constraints dde -body { +# that utf-8 is sent (e.g. "c3 84" on the wire) +test winDde-3.6 {DDE request utf-8} -constraints dde -body { set \xe1 "not set" dde execute TclEval self "set \xe1 \xc4" scan [set \xe1] %c } -result 196 # Set variable a to A with diaeresis (unicode C4) using binary execute # and compose utf-8 (e.g. "c3 84" ) manualy -test winDde-3.7 {DDE request binary} -constraints dde -body { +test winDde-3.7 {DDE request binary} -constraints {dde notWine} -body { set \xe1 "not set" dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00] scan [set \xe1] %c @@ -279,19 +279,19 @@ test winDde-6.6 {DDE remote servername collision force} -constraints {dde stdio} # ------------------------------------------------------------------------- -test winDde-7.1 {Load DDE in slave interpreter} -constraints dde -setup { - interp create slave +test winDde-7.1 {Load DDE in child interpreter} -constraints dde -setup { + interp create child } -body { - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.1] + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.1] } -cleanup { - interp delete slave + interp delete child } -result {dde-interp-7.1} -test winDde-7.2 {DDE slave cleanup} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.5] - interp delete slave +test winDde-7.2 {DDE child cleanup} -constraints dde -setup { + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.5] + interp delete child } -body { dde services TclEval {} set s [dde services TclEval {}] @@ -300,128 +300,128 @@ test winDde-7.2 {DDE slave cleanup} -constraints dde -setup { set s } } -result {} -test winDde-7.3 {DDE present in slave interp} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.3] +test winDde-7.3 {DDE present in child interp} -constraints dde -setup { + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.3] } -body { dde services TclEval dde-interp-7.3 } -cleanup { - interp delete slave + interp delete child } -result {{TclEval dde-interp-7.3}} test winDde-7.4 {interp name collision with -force} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.4] + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.4] } -body { dde servername -force -- dde-interp-7.4 } -cleanup { - interp delete slave + interp delete child } -result {dde-interp-7.4} test winDde-7.5 {interp name collision without -force} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.5] + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.5] } -body { dde servername -- dde-interp-7.5 } -cleanup { - interp delete slave + interp delete child } -result "dde-interp-7.5 #2" # ------------------------------------------------------------------------- test winDde-8.1 {Safe DDE load} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde + interp create -safe child + child invokehidden load $::ddelib Dde } -body { - slave eval dde servername slave + child eval dde servername child } -cleanup { - interp delete slave + interp delete child } -returnCodes error -result {invalid command name "dde"} test winDde-8.2 {Safe DDE set servername} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde + interp create -safe child + child invokehidden load $::ddelib Dde } -body { - slave invokehidden dde servername slave -} -cleanup {interp delete slave} -result {slave} + child invokehidden dde servername child +} -cleanup {interp delete child} -result {child} test winDde-8.3 {Safe DDE check handler required for eval} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave invokehidden dde servername slave + interp create -safe child + child invokehidden load $::ddelib Dde + child invokehidden dde servername child } -body { - catch {dde eval slave set a 1} msg -} -cleanup {interp delete slave} -result {1} + catch {dde eval child set a 1} msg +} -cleanup {interp delete child} -result {1} test winDde-8.4 {Safe DDE check that execute is denied} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave invokehidden dde servername slave + interp create -safe child + child invokehidden load $::ddelib Dde + child invokehidden dde servername child } -body { - slave eval set a 1 - dde execute TclEval slave {set a 2} - slave eval set a -} -cleanup {interp delete slave} -result 1 + child eval set a 1 + dde execute TclEval child {set a 2} + child eval set a +} -cleanup {interp delete child} -result 1 test winDde-8.5 {Safe DDE check that request is denied} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave invokehidden dde servername slave + interp create -safe child + child invokehidden load $::ddelib Dde + child invokehidden dde servername child } -body { - slave eval set a 1 - dde request TclEval slave a + child eval set a 1 + dde request TclEval child a } -cleanup { - interp delete slave + interp delete child } -returnCodes error -result {remote server cannot handle this command} test winDde-8.6 {Safe DDE assign handler procedure} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} } -body { - slave invokehidden dde servername -handler DDEACCEPT slave -} -cleanup {interp delete slave} -result slave + child invokehidden dde servername -handler DDEACCEPT child +} -cleanup {interp delete child} -result child test winDde-8.7 {Safe DDE check simple command} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave set x 1 -} -cleanup {interp delete slave} -result {set x 1} + dde eval child set x 1 +} -cleanup {interp delete child} -result {set x 1} test winDde-8.8 {Safe DDE check non-list command} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} + child invokehidden dde servername -handler DDEACCEPT child } -body { set s "c:\\Program Files\\Microsoft Visual Studio\\" - dde eval slave $s - string equal [slave eval set DDECMD] $s -} -cleanup {interp delete slave} -result 1 + dde eval child $s + string equal [child eval set DDECMD] $s +} -cleanup {interp delete child} -result 1 test winDde-8.9 {Safe DDE check command evaluation} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave set \xe1 1 - slave eval set \xe1 -} -cleanup {interp delete slave} -result 1 + dde eval child set \xe1 1 + child eval set \xe1 +} -cleanup {interp delete child} -result 1 test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave [list set x 1] - slave eval set x -} -cleanup {interp delete slave} -result 1 + dde eval child [list set x 1] + child eval set x +} -cleanup {interp delete child} -result 1 test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave [list [list set x 1]] - slave eval set x -} -cleanup {interp delete slave} -returnCodes error -result {invalid command name "set x 1"} + dde eval child [list [list set x 1]] + child eval set x +} -cleanup {interp delete child} -returnCodes error -result {invalid command name "set x 1"} # ------------------------------------------------------------------------- @@ -481,7 +481,7 @@ test winDde-9.4 {External safe DDE check null data passing} -constraints {dde st # ------------------------------------------------------------------------- #cleanup -#catch {interp delete $slave}; # ensure we clean up the slave. +#catch {interp delete $child}; # ensure we clean up the child. file delete -force $::scriptName ::tcltest::cleanupTests return diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 6dde045..70db379 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -11,7 +11,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -29,6 +29,7 @@ testConstraint cdrom 0 testConstraint exdev 0 testConstraint longFileNames 0 testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}] +testConstraint notWine [expr {$::tcl_platform(platform) ne "windows" || ![info exists ::env(TRAVIS_OS_NAME)] || ![string match linux $::env(TRAVIS_OS_NAME)]}] proc createfile {file {string a}} { set f [open $file w] @@ -132,25 +133,25 @@ test winFCmd-1.1 {TclpRenameFile: errno: EACCES} -body { } -constraints {win cdrom testfile} -returnCodes error -result EACCES test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notWine} -body { file mkdir td1/td2/td3 file mkdir td2 testfile mv td2 td1/td2 } -returnCodes error -result EEXIST test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notWine} -body { testfile mv / td1 } -returnCodes error -result EINVAL test winFCmd-1.4 {TclpRenameFile: errno: EINVAL} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notWine} -body { file mkdir td1 testfile mv td1 td1/td2 } -returnCodes error -result EINVAL test winFCmd-1.5 {TclpRenameFile: errno: EISDIR} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notWine} -body { file mkdir td1 createfile tf1 testfile mv tf1 td1 @@ -255,7 +256,7 @@ test winFCmd-1.22 {TclpRenameFile: long dst} -setup { } -returnCodes error -result ENAMETOOLONG test winFCmd-1.23 {TclpRenameFile: move dir into self} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notWine} -body { file mkdir td1 testfile mv [pwd]/td1 td1/td2 } -returnCodes error -result EINVAL @@ -300,21 +301,21 @@ test winFCmd-1.29 {TclpRenameFile: src is dir} -setup { } -returnCodes error -result ENOTDIR test winFCmd-1.30 {TclpRenameFile: dst is dir} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notWine} -body { file mkdir td1 file mkdir td2/td2 testfile mv td1 td2 } -returnCodes error -result EEXIST test winFCmd-1.31 {TclpRenameFile: TclpRemoveDirectory fails} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notWine} -body { file mkdir td1 file mkdir td2/td2 testfile mv td1 td2 } -returnCodes error -result EEXIST test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory succeeds} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notWine} -body { file mkdir td1/td2 file mkdir td2 testfile mv td1 td2 @@ -343,7 +344,7 @@ test winFCmd-1.34 {TclpRenameFile: src is dir, dst is not} -setup { } -returnCodes error -result ENOTDIR test winFCmd-1.35 {TclpRenameFile: src is not dir, dst is} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notWine} -body { file mkdir td1 createfile tf1 testfile mv tf1 td1 @@ -384,7 +385,7 @@ proc MakeFiles {dirname} { set f [open $filename w] close $f file stat $filename stat - if {[set n [lsearch -exact -integer $inodes $stat(ino)]] != -1} { + if {[set n [lsearch -exact -integer $inodes $stat(ino)]] >= 0} { return [list [file join $dirname Test$n] $filename] } lappend inodes $stat(ino) @@ -394,7 +395,7 @@ proc MakeFiles {dirname} { test winFCmd-1.38 {TclpRenameFile: check rename of conflicting inodes} -setup { cleanup -} -constraints {win winNonZeroInodes knownMsvcBug} -body { +} -constraints {win winNonZeroInodes knownMsvcBug notWine} -body { file mkdir td1 foreach {a b} [MakeFiles td1] break file rename -force $a $b @@ -639,7 +640,7 @@ test winFCmd-5.1 {TclpCopyDirectory: calls TraverseWinTree} -setup { test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} -setup { cleanup -} -constraints {winVista testfile testchmod knownMsvcBug} -body { +} -constraints {winVista testfile testchmod knownMsvcBug notWine} -body { file mkdir td1 testchmod 0 td1 testfile rmdir td1 @@ -693,7 +694,7 @@ test winFCmd-6.8 {TclpRemoveDirectory: RemoveDirectory fails} -setup { } -result {1 {tf1 ENOTDIR}} test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup { cleanup -} -constraints {winVista testfile testchmod knownMsvcBug} -body { +} -constraints {winVista testfile testchmod knownMsvcBug notWine} -body { file mkdir td1 testchmod 0 td1 testfile rmdir td1 @@ -704,14 +705,14 @@ test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup { } -result {td1 EACCES} test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notWine} -body { testfile rmdir / # WinXP returns EEXIST, WinNT seems to return EACCES. No policy # decision has been made as to which is correct. } -returnCodes error -match regexp -result {^/ E(ACCES|EXIST)$} test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup { cleanup -} -constraints {winVista testfile testchmod knownMsvcBug} -body { +} -constraints {winVista testfile testchmod knownMsvcBug notWine} -body { file mkdir td1 testchmod 0 td1 testfile rmdir td1 @@ -940,7 +941,7 @@ test winFCmd-9.1 {TraversalDelete: DOTREE_F} -setup { } -result {} test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup { cleanup -} -constraints {winVista testfile testchmod knownMsvcBug} -body { +} -constraints {winVista testfile testchmod knownMsvcBug notWine} -body { file mkdir td1/td2 testchmod 0 td1 testfile rmdir -force td1 @@ -1129,7 +1130,7 @@ test winFCmd-15.2 {SetWinFileAttributes - archive} -constraints {win} -setup { } -cleanup { cleanup } -result {{} 1} -test winFCmd-15.3 {SetWinFileAttributes - archive} -constraints {win} -setup { +test winFCmd-15.3 {SetWinFileAttributes - archive} -constraints {win notWine} -setup { cleanup } -body { createfile td1 {} @@ -1137,7 +1138,7 @@ test winFCmd-15.3 {SetWinFileAttributes - archive} -constraints {win} -setup { } -cleanup { cleanup } -result {{} 0} -test winFCmd-15.4 {SetWinFileAttributes - hidden} -constraints {win} -setup { +test winFCmd-15.4 {SetWinFileAttributes - hidden} -constraints {win notWine} -setup { cleanup } -body { createfile td1 {} @@ -1170,7 +1171,7 @@ test winFCmd-15.7 {SetWinFileAttributes - readonly} -setup { } -cleanup { cleanup } -result {{} 0} -test winFCmd-15.8 {SetWinFileAttributes - system} -constraints {win} -setup { +test winFCmd-15.8 {SetWinFileAttributes - system} -constraints {win notWine} -setup { cleanup } -body { createfile td1 {} diff --git a/tests/winFile.test b/tests/winFile.test index b288063..2c0988a 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -10,11 +10,10 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2.0.2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } -namespace import -force ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -25,6 +24,7 @@ testConstraint notNTFS 0 if {[testConstraint testvolumetype]} { testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}] } +testConstraint notWine [expr {$::tcl_platform(platform) ne "windows" || ![info exists ::env(TRAVIS_OS_NAME)] || ![string match linux $::env(TRAVIS_OS_NAME)]}] test winFile-1.1 {TclpGetUserHome} -constraints {win} -body { glob ~nosuchuser @@ -151,7 +151,7 @@ if {[testConstraint win]} { test winFile-4.0 { Enhanced NTFS user/group permissions: test no acccess } -constraints { - win notNTFS + win notNTFS notWine } -setup { set owner [getuser $fname] set user $::env(USERDOMAIN)\\$::env(USERNAME) @@ -166,7 +166,7 @@ test winFile-4.0 { test winFile-4.1 { Enhanced NTFS user/group permissions: test readable only } -constraints { - win notNTFS + win notNTFS notWine } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { @@ -177,7 +177,7 @@ test winFile-4.1 { test winFile-4.2 { Enhanced NTFS user/group permissions: test writable only } -constraints { - win notNTFS + win notNTFS notWine } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { diff --git a/tests/winNotify.test b/tests/winNotify.test index 3e48dbf..0433b4a 100644 --- a/tests/winNotify.test +++ b/tests/winNotify.test @@ -11,7 +11,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/winPipe.test b/tests/winPipe.test index 7e01c5f..919e336 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -12,8 +12,10 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} unset -nocomplain path catch { @@ -26,6 +28,9 @@ set org_pwd [pwd] set bindir [file join $org_pwd [file dirname [info nameofexecutable]]] set cat32 [file join $bindir cat32.exe] +testConstraint notWine [expr {$::tcl_platform(platform) ne "windows" || ![info exists ::env(TRAVIS_OS_NAME)] || ![string match linux $::env(TRAVIS_OS_NAME)]}] + + # several test-cases here expect current directory == [temporaryDirectory]: cd [temporaryDirectory] @@ -195,7 +200,7 @@ test winpipe-4.1 {Tcl_WaitPid} {win exec cat32} { vwait x list $result $x [contents $path(stderr)] } "{$big} 1 stderr32" -test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept} { +test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept notWine} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] puts $f "load $::tcltestlib Tcltest" @@ -203,7 +208,7 @@ test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec test set status [catch {close $f}] list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2] } {1 1 SIGFPE} -test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec testexcept} { +test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec testexcept notWine} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] puts $f "load $::tcltestlib Tcltest" @@ -211,7 +216,7 @@ test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec tes set status [catch {close $f}] list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2] } {1 1 SIGSEGV} -test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec testexcept} { +test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec testexcept notWine} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] puts $f "load $::tcltestlib Tcltest" @@ -219,7 +224,7 @@ test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec test set status [catch {close $f}] list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2] } {1 1 SIGILL} -test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec testexcept} { +test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec testexcept notWine} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] puts $f "load $::tcltestlib Tcltest" @@ -517,7 +522,7 @@ test winpipe-8.2 {BuildCommandLine/parse_cmdline pass-thru: check injection on s } -result {} test winpipe-8.3 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (jointly)} \ --constraints {win exec} -body { +-constraints {win exec notWine} -body { _testExecArgs 0 \ [list START {*}$injectList END] \ [list "START\"" {*}$injectList END] \ @@ -526,7 +531,7 @@ test winpipe-8.3 {BuildCommandLine/parse_cmdline pass-thru: check injection on s } -result {} test winpipe-8.4 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (command/jointly args)} \ --constraints {win exec} -body { +-constraints {win exec notWine} -body { _testExecArgs 2 \ [list START {*}$injectList END] \ [list "START\"" {*}$injectList END] \ @@ -535,7 +540,7 @@ test winpipe-8.4 {BuildCommandLine/parse_cmdline pass-thru: check injection on s } -result {} test winpipe-8.5 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (random mix)} \ --constraints {win exec} -body { +-constraints {win exec notWine} -body { set lst {} set maps { {\&|^<>!()%} diff --git a/tests/winTime.test b/tests/winTime.test index 6a7aedb..19e4c58 100644 --- a/tests/winTime.test +++ b/tests/winTime.test @@ -11,7 +11,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/zipfs.test b/tests/zipfs.test index 2ecbdfa..017193b 100644 --- a/tests/zipfs.test +++ b/tests/zipfs.test @@ -11,7 +11,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/zlib.test b/tests/zlib.test index 463cc7c..1461c43 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -11,7 +11,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tools/checkLibraryDoc.tcl b/tools/checkLibraryDoc.tcl index 6d147ac..8dba5b4 100755..100644 --- a/tools/checkLibraryDoc.tcl +++ b/tools/checkLibraryDoc.tcl @@ -3,7 +3,7 @@ # This script attempts to determine what APIs exist in the source base that # have not been documented. By grepping through all of the doc/*.3 man # pages, looking for "Pkg_*" (e.g., Tcl_ or Tk_), and comparing this list -# against the list of Pkg_ APIs found in the source (e.g., tcl8.2/*/*.[ch]) +# against the list of Pkg_ APIs found in the source (e.g., tcl8.7/*/*.[ch]) # we create six lists: # 1) APIs in Source not in Docs. # 2) APIs in Docs not in Source. @@ -69,6 +69,7 @@ set StructList { Tk_GeomMgr \ Tk_Image \ Tk_ImageMaster \ + Tk_ImageModel \ Tk_ImageType \ Tk_Item \ Tk_ItemType \ @@ -106,7 +107,6 @@ proc main {} { if {($len != 2) && ($len != 3)} { puts "usage: $argv0 pkgName pkgDir \[outFile\]" puts " pkgName == Tcl,Tk" - puts " pkgDir == /home/surles/cvs/tcl8.2" exit 1 } diff --git a/tools/loadICU.tcl b/tools/loadICU.tcl index e07b126..a3079f5 100755 --- a/tools/loadICU.tcl +++ b/tools/loadICU.tcl @@ -591,7 +591,7 @@ proc backslashify { string } { set retval {} foreach char [split $string {}] { scan $char %c ccode - if { $ccode >= 0x0020 && $ccode < 0x007F && $char ne "\"" + if { $ccode >= 0x20 && $ccode < 0x7F && $char ne "\"" && $char ne "\{" && $char ne "\}" && $char ne "\[" && $char ne "\]" && $char ne "\\" && $char ne "\$" } { append retval $char diff --git a/tools/makeHeader.tcl b/tools/makeHeader.tcl index e9b7ed1..dd2f199 100644 --- a/tools/makeHeader.tcl +++ b/tools/makeHeader.tcl @@ -70,7 +70,7 @@ namespace eval makeHeader { set from [lsearch -glob $data $BEGIN] set to [lsearch -glob $data $END] - if {$from == -1 || $to == -1 || $from >= $to} { + if {$from < 0 || $to < 0 || $from >= $to} { throw BAD "not a template" } diff --git a/tools/man2help2.tcl b/tools/man2help2.tcl index 4f3b7e5..91c81be 100644 --- a/tools/man2help2.tcl +++ b/tools/man2help2.tcl @@ -157,7 +157,7 @@ proc text {string} { "\t" {\tab } \ '' "\\rdblquote " \ `` "\\ldblquote " \ - "\u00b7" "\\bullet " \ + "\xB7" "\\bullet " \ ] $string] # Check if this is the beginning of an international character string. @@ -824,7 +824,7 @@ proc IPmacro {argList} { set indent 5 } if {$text == {\(bu}} { - set text "\u00b7" + set text "\xB7" } set tab [expr {$indent * 0.1}]i diff --git a/tools/mkdepend.tcl b/tools/mkdepend.tcl index 3d96a5e..b1ad076 100644 --- a/tools/mkdepend.tcl +++ b/tools/mkdepend.tcl @@ -88,7 +88,7 @@ proc readDepends {chan} { set line "" array set depends {} - while {[gets $chan line] != -1} { + while {[gets $chan line] >= 0} { if {[regexp {^#line [0-9]+ \"(.*)\"$} $line dummy fname] != 0} { set fname [file normalize $fname] if {![info exists target]} { diff --git a/tools/tclZIC.tcl b/tools/tclZIC.tcl index 85c9ba9..6282111 100755 --- a/tools/tclZIC.tcl +++ b/tools/tclZIC.tcl @@ -36,7 +36,7 @@ set olsonFiles { africa antarctica asia australasia backward etcetera europe northamerica - pacificnew southamerica systemv + southamerica } # Define the year at which the DST information will stop. diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index 517360b..c81acce 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -629,6 +629,7 @@ array set remap_link_target { Tk_Font Tk_GetFont Tk_Image Tk_GetImage Tk_ImageMaster Tk_GetImage + Tk_ImageModel Tk_GetImage Tk_ItemType Tk_CreateItemType Tk_Justify Tk_GetJustify Ttk_Theme Ttk_GetTheme diff --git a/tools/uniParse.tcl b/tools/uniParse.tcl index a451096..545afc4 100644 --- a/tools/uniParse.tcl +++ b/tools/uniParse.tcl @@ -68,7 +68,7 @@ proc uni::getGroup {value} { variable groups set gIndex [lsearch -exact $groups $value] - if {$gIndex == -1} { + if {$gIndex < 0} { set gIndex [llength $groups] lappend groups $value } @@ -81,7 +81,7 @@ proc uni::addPage {info} { variable shift set pIndex [lsearch -exact $pages $info] - if {$pIndex == -1} { + if {$pIndex < 0} { set pIndex [llength $pages] lappend pages $info } diff --git a/unix/Makefile.in b/unix/Makefile.in index b7a4d03..96ace8c 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -961,7 +961,8 @@ install: $(INSTALL_TARGETS) install-strip: $(MAKE) $(INSTALL_TARGETS) \ - INSTALL_PROGRAM="$(INSTALL_PROGRAM) ${INSTALL_STRIP_PROGRAM}" + INSTALL_PROGRAM="$(INSTALL_PROGRAM) ${INSTALL_STRIP_PROGRAM}" \ + INSTALL_LIBRARY="$(INSTALL_LIBRARY) ${INSTALL_STRIP_LIBRARY}" install-binaries: binaries @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" \ @@ -1039,9 +1040,9 @@ install-libraries: libraries @for i in $(TOP_DIR)/library/cookiejar/*.gz; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done - @echo "Installing package http 2.9.3 as a Tcl Module" + @echo "Installing package http 2.10.0a1 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \ - "$(MODULE_INSTALL_DIR)/8.6/http-2.9.3.tm" + "$(MODULE_INSTALL_DIR)/8.6/http-2.10.0a1.tm" @echo "Installing package opt 0.4.7" @for i in $(TOP_DIR)/library/opt/*.tcl; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ @@ -2208,9 +2209,9 @@ rpm: all -rm -rf RPMS THIS.TCL.SPEC # -# Target to create a proper Tcl distribution from information in the master -# source directory. DISTDIR must be defined to indicate where to put the -# distribution. DISTDIR must be an absolute path name. +# Target to create a proper Tcl distribution from information in the +# source directory. DISTDIR must be defined to indicate where to put +# the distribution. DISTDIR must be an absolute path name. # DISTROOT = /tmp/dist diff --git a/unix/README b/unix/README index 3340dc6..3c1a207 100644 --- a/unix/README +++ b/unix/README @@ -91,7 +91,7 @@ How To Compile And Install Tcl: for descriptions of the probes made available, see http://wiki.tcl.tk/DTrace for more details --with-encoding=ENCODING Specifies the encoding for compile-time - configuration values. Defaults to iso8859-1, + configuration values. Defaults to utf-8, which is also sufficient for ASCII. --with-tzdata=FLAG Specifies whether to install timezone data. By default, the configure script tries to detect diff --git a/unix/configure b/unix/configure index d3a4856..62b1257 100755 --- a/unix/configure +++ b/unix/configure @@ -1430,7 +1430,7 @@ Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-encoding encoding for configuration values (default: - iso8859-1) + utf-8) --with-system-libtommath use external libtommath (default: true if available, false otherwise) @@ -3982,7 +3982,7 @@ _ACEOF else -$as_echo "#define TCL_CFGVAL_ENCODING \"iso8859-1\"" >>confdefs.h +$as_echo "#define TCL_CFGVAL_ENCODING \"utf-8\"" >>confdefs.h fi @@ -5036,7 +5036,7 @@ fi if test "$GCC" = yes; then : CFLAGS_OPTIMIZE=-O2 - CFLAGS_WARNING="-Wall -Wextra -Wwrite-strings -Wpointer-arith" + CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith" case "${CC}" in *++|*++-*) ;; @@ -8639,7 +8639,7 @@ else int main () { -struct tm tm; tm.tm_gmtoff; +struct tm tm; (void)tm.tm_gmtoff; ; return 0; } diff --git a/unix/dltest/pkga.c b/unix/dltest/pkga.c index 5bf3c1e..b2267a7 100644 --- a/unix/dltest/pkga.c +++ b/unix/dltest/pkga.c @@ -50,6 +50,7 @@ Pkga_EqObjCmd( int result; const char *str1, *str2; int len1, len2; + (void)dummy; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "string1 string2"); @@ -91,6 +92,8 @@ Pkga_QuoteObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { + (void)dummy; + if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "value"); return TCL_ERROR; diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index f102496..32e2d73 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -54,6 +54,7 @@ Pkgb_SubObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int first, second; + (void)dummy; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "num num"); @@ -94,6 +95,10 @@ Pkgb_UnsafeObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + (void)dummy; + (void)objc; + (void)objv; + return Tcl_EvalEx(interp, "list unsafe command invoked", -1, TCL_EVAL_GLOBAL); } @@ -106,6 +111,9 @@ Pkgb_DemoObjCmd( { #if (TCL_MAJOR_VERSION > 8) || (TCL_MINOR_VERSION > 4) Tcl_Obj *first; + (void)dummy; + (void)objc; + (void)objv; if (Tcl_ListObjIndex(NULL, Tcl_GetEncodingSearchPath(), 0, &first) == TCL_OK) { diff --git a/unix/dltest/pkgc.c b/unix/dltest/pkgc.c index 983fcf3..a2c4db1 100644 --- a/unix/dltest/pkgc.c +++ b/unix/dltest/pkgc.c @@ -48,6 +48,7 @@ Pkgc_SubObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int first, second; + (void)dummy; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "num num"); @@ -85,6 +86,10 @@ Pkgc_UnsafeObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + (void)dummy; + (void)objc; + (void)objv; + Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1)); return TCL_OK; } diff --git a/unix/dltest/pkgd.c b/unix/dltest/pkgd.c index c708df0..e0986f7 100644 --- a/unix/dltest/pkgd.c +++ b/unix/dltest/pkgd.c @@ -48,6 +48,7 @@ Pkgd_SubObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int first, second; + (void)dummy; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "num num"); @@ -85,6 +86,10 @@ Pkgd_UnsafeObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + (void)dummy; + (void)objc; + (void)objv; + Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1)); return TCL_OK; } diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c index 5a0b0ef..9aebc3f 100644 --- a/unix/dltest/pkgooa.c +++ b/unix/dltest/pkgooa.c @@ -38,6 +38,8 @@ Pkgooa_StubsOKObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + (void)dummy; + if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, ""); return TCL_ERROR; @@ -76,9 +78,13 @@ static TclOOStubs stubsCopy = { * a function with a different memory address than * the real Tcl_CopyObjectInstance function in Tcl. */ (Tcl_Object (*) (Tcl_Interp *, Tcl_Object, const char *, - const char *t)) Pkgooa_StubsOKObjCmd + const char *t))(void *)Pkgooa_StubsOKObjCmd, /* More entries could be here, but those are not used * for this test-case. So, being NULL is OK. */ + NULL, NULL, NULL, NULL, NULL, NULL, NULL, + NULL, NULL, NULL, NULL, NULL, NULL, NULL, + NULL, NULL, NULL, NULL, NULL, NULL, NULL, + NULL, NULL, NULL, NULL, NULL, NULL, NULL, }; extern DLLEXPORT int diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c index 9d5a9d9..1c7b46f 100644 --- a/unix/dltest/pkgua.c +++ b/unix/dltest/pkgua.c @@ -125,6 +125,7 @@ PkguaEqObjCmd( int result; const char *str1, *str2; int len1, len2; + (void)dummy; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "string1 string2"); @@ -166,6 +167,8 @@ PkguaQuoteObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { + (void)dummy; + if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "value"); return TCL_ERROR; diff --git a/unix/install-sh b/unix/install-sh index 7c34c3f..21b733a 100755 --- a/unix/install-sh +++ b/unix/install-sh @@ -1,7 +1,7 @@ #!/bin/sh # install - install a program, script, or datafile -scriptversion=2011-04-20.01; # UTC +scriptversion=2020-07-26.22; # UTC # This originates from X11R5 (mit/util/scripts/install.sh), which was # later released in X11R6 (xc/config/util/install.sh) with the @@ -35,25 +35,21 @@ scriptversion=2011-04-20.01; # UTC # FSF changes to this file are in the public domain. # # Calling this script install-sh is preferred over install.sh, to prevent -# `make' implicit rules from creating a file called install from it +# 'make' implicit rules from creating a file called install from it # when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. +tab=' ' nl=' ' -IFS=" "" $nl" +IFS=" $tab$nl" -# set DOITPROG to echo to test this script +# Set DOITPROG to "echo" to test this script. -# Don't use :- since 4.3BSD and earlier shells don't like it. doit=${DOITPROG-} -if test -z "$doit"; then - doit_exec=exec -else - doit_exec=$doit -fi +doit_exec=${doit:-exec} # Put in absolute file names if you don't have them in your path; # or use environment vars. @@ -68,22 +64,15 @@ mvprog=${MVPROG-mv} rmprog=${RMPROG-rm} stripprog=${STRIPPROG-strip} -posix_glob='?' -initialize_posix_glob=' - test "$posix_glob" != "?" || { - if (set -f) 2>/dev/null; then - posix_glob= - else - posix_glob=: - fi - } -' - posix_mkdir= # Desired mode of installed file. mode=0755 +# Create dirs (including intermediate dirs) using mode 755. +# This is like GNU 'install' as of coreutils 8.32 (2020). +mkdir_umask=22 + chgrpcmd= chmodcmd=$chmodprog chowncmd= @@ -97,7 +86,7 @@ dir_arg= dst_arg= copy_on_change=false -no_target_directory= +is_target_a_directory=possibly usage="\ Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE @@ -120,7 +109,7 @@ Options: -m MODE $chmodprog installed files to MODE. -o USER $chownprog installed files to USER. -s $stripprog installed files. - -S $stripprog installed files. + -S OPTION $stripprog installed files using OPTION. -t DIRECTORY install into DIRECTORY. -T report an error if DSTFILE is a directory. @@ -138,45 +127,60 @@ while test $# -ne 0; do -d) dir_arg=true;; -g) chgrpcmd="$chgrpprog $2" - shift;; + shift;; --help) echo "$usage"; exit $?;; -m) mode=$2 - case $mode in - *' '* | *' '* | *' -'* | *'*'* | *'?'* | *'['*) - echo "$0: invalid mode: $mode" >&2 - exit 1;; - esac - shift;; + case $mode in + *' '* | *"$tab"* | *"$nl"* | *'*'* | *'?'* | *'['*) + echo "$0: invalid mode: $mode" >&2 + exit 1;; + esac + shift;; -o) chowncmd="$chownprog $2" - shift;; + shift;; -s) stripcmd=$stripprog;; -S) stripcmd="$stripprog $2" - shift;; + shift;; - -t) dst_arg=$2 - shift;; + -t) + is_target_a_directory=always + dst_arg=$2 + # Protect names problematic for 'test' and other utilities. + case $dst_arg in + -* | [=\(\)!]) dst_arg=./$dst_arg;; + esac + shift;; - -T) no_target_directory=true;; + -T) is_target_a_directory=never;; --version) echo "$0 $scriptversion"; exit $?;; - --) shift - break;; + --) shift + break;; - -*) echo "$0: invalid option: $1" >&2 - exit 1;; + -*) echo "$0: invalid option: $1" >&2 + exit 1;; *) break;; esac shift done +# We allow the use of options -d and -T together, by making -d +# take the precedence; this is for compatibility with GNU install. + +if test -n "$dir_arg"; then + if test -n "$dst_arg"; then + echo "$0: target directory not allowed when installing a directory." >&2 + exit 1 + fi +fi + if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then # When -d is used, all remaining arguments are directories to create. # When -t is used, the destination is already specified. @@ -190,6 +194,10 @@ if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then fi shift # arg dst_arg=$arg + # Protect names problematic for 'test' and other utilities. + case $dst_arg in + -* | [=\(\)!]) dst_arg=./$dst_arg;; + esac done fi @@ -198,12 +206,21 @@ if test $# -eq 0; then echo "$0: no input file specified." >&2 exit 1 fi - # It's OK to call `install-sh -d' without argument. + # It's OK to call 'install-sh -d' without argument. # This can happen when creating conditional directories. exit 0 fi if test -z "$dir_arg"; then + if test $# -gt 1 || test "$is_target_a_directory" = always; then + if test ! -d "$dst_arg"; then + echo "$0: $dst_arg: Is not a directory." >&2 + exit 1 + fi + fi +fi + +if test -z "$dir_arg"; then do_exit='(exit $ret); exit $ret' trap "ret=129; $do_exit" 1 trap "ret=130; $do_exit" 2 @@ -219,16 +236,16 @@ if test -z "$dir_arg"; then *[0-7]) if test -z "$stripcmd"; then - u_plus_rw= + u_plus_rw= else - u_plus_rw='% 200' + u_plus_rw='% 200' fi cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; *) if test -z "$stripcmd"; then - u_plus_rw= + u_plus_rw= else - u_plus_rw=,u+rw + u_plus_rw=,u+rw fi cp_umask=$mode$u_plus_rw;; esac @@ -236,9 +253,9 @@ fi for src do - # Protect names starting with `-'. + # Protect names problematic for 'test' and other utilities. case $src in - -*) src=./$src;; + -* | [=\(\)!]) src=./$src;; esac if test -n "$dir_arg"; then @@ -260,185 +277,150 @@ do echo "$0: no destination specified." >&2 exit 1 fi - dst=$dst_arg - # Protect names starting with `-'. - case $dst in - -*) dst=./$dst;; - esac - # If destination is a directory, append the input filename; won't work - # if double slashes aren't ignored. + # If destination is a directory, append the input filename. if test -d "$dst"; then - if test -n "$no_target_directory"; then - echo "$0: $dst_arg: Is a directory" >&2 - exit 1 + if test "$is_target_a_directory" = never; then + echo "$0: $dst_arg: Is a directory" >&2 + exit 1 fi dstdir=$dst - dst=$dstdir/`basename "$src"` + dstbase=`basename "$src"` + case $dst in + */) dst=$dst$dstbase;; + *) dst=$dst/$dstbase;; + esac dstdir_status=0 else - # Prefer dirname, but fall back on a substitute if dirname fails. - dstdir=` - (dirname "$dst") 2>/dev/null || - expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$dst" : 'X\(//\)[^/]' \| \ - X"$dst" : 'X\(//\)$' \| \ - X"$dst" : 'X\(/\)' \| . 2>/dev/null || - echo X"$dst" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q' - ` - + dstdir=`dirname "$dst"` test -d "$dstdir" dstdir_status=$? fi fi + case $dstdir in + */) dstdirslash=$dstdir;; + *) dstdirslash=$dstdir/;; + esac + obsolete_mkdir_used=false if test $dstdir_status != 0; then case $posix_mkdir in '') - # Create intermediate dirs using mode 755 as modified by the umask. - # This is like FreeBSD 'install' as of 1997-10-28. - umask=`umask` - case $stripcmd.$umask in - # Optimize common cases. - *[2367][2367]) mkdir_umask=$umask;; - .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; - - *[0-7]) - mkdir_umask=`expr $umask + 22 \ - - $umask % 100 % 40 + $umask % 20 \ - - $umask % 10 % 4 + $umask % 2 - `;; - *) mkdir_umask=$umask,go-w;; - esac - - # With -d, create the new directory with the user-specified mode. - # Otherwise, rely on $mkdir_umask. - if test -n "$dir_arg"; then - mkdir_mode=-m$mode + # With -d, create the new directory with the user-specified mode. + # Otherwise, rely on $mkdir_umask. + if test -n "$dir_arg"; then + mkdir_mode=-m$mode + else + mkdir_mode= + fi + + posix_mkdir=false + # The $RANDOM variable is not portable (e.g., dash). Use it + # here however when possible just to lower collision chance. + tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ + + trap ' + ret=$? + rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" 2>/dev/null + exit $ret + ' 0 + + # Because "mkdir -p" follows existing symlinks and we likely work + # directly in world-writeable /tmp, make sure that the '$tmpdir' + # directory is successfully created first before we actually test + # 'mkdir -p'. + if (umask $mkdir_umask && + $mkdirprog $mkdir_mode "$tmpdir" && + exec $mkdirprog $mkdir_mode -p -- "$tmpdir/a/b") >/dev/null 2>&1 + then + if test -z "$dir_arg" || { + # Check for POSIX incompatibilities with -m. + # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or + # other-writable bit of parent directory when it shouldn't. + # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. + test_tmpdir="$tmpdir/a" + ls_ld_tmpdir=`ls -ld "$test_tmpdir"` + case $ls_ld_tmpdir in + d????-?r-*) different_mode=700;; + d????-?--*) different_mode=755;; + *) false;; + esac && + $mkdirprog -m$different_mode -p -- "$test_tmpdir" && { + ls_ld_tmpdir_1=`ls -ld "$test_tmpdir"` + test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" + } + } + then posix_mkdir=: + fi + rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" else - mkdir_mode= + # Remove any dirs left behind by ancient mkdir implementations. + rmdir ./$mkdir_mode ./-p ./-- "$tmpdir" 2>/dev/null fi - - posix_mkdir=false - case $umask in - *[123567][0-7][0-7]) - # POSIX mkdir -p sets u+wx bits regardless of umask, which - # is incompatible with FreeBSD 'install' when (umask & 300) != 0. - ;; - *) - tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ - trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0 - - if (umask $mkdir_umask && - exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1 - then - if test -z "$dir_arg" || { - # Check for POSIX incompatibilities with -m. - # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or - # other-writeable bit of parent directory when it shouldn't. - # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. - ls_ld_tmpdir=`ls -ld "$tmpdir"` - case $ls_ld_tmpdir in - d????-?r-*) different_mode=700;; - d????-?--*) different_mode=755;; - *) false;; - esac && - $mkdirprog -m$different_mode -p -- "$tmpdir" && { - ls_ld_tmpdir_1=`ls -ld "$tmpdir"` - test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" - } - } - then posix_mkdir=: - fi - rmdir "$tmpdir/d" "$tmpdir" - else - # Remove any dirs left behind by ancient mkdir implementations. - rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null - fi - trap '' 0;; - esac;; + trap '' 0;; esac if $posix_mkdir && ( - umask $mkdir_umask && - $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" + umask $mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" ) then : else - # The umask is ridiculous, or mkdir does not conform to POSIX, + # mkdir does not conform to POSIX, # or it failed possibly due to a race condition. Create the # directory the slow way, step by step, checking for races as we go. case $dstdir in - /*) prefix='/';; - -*) prefix='./';; - *) prefix='';; + /*) prefix='/';; + [-=\(\)!]*) prefix='./';; + *) prefix='';; esac - eval "$initialize_posix_glob" - oIFS=$IFS IFS=/ - $posix_glob set -f + set -f set fnord $dstdir shift - $posix_glob set +f + set +f IFS=$oIFS prefixes= for d do - test -z "$d" && continue - - prefix=$prefix$d - if test -d "$prefix"; then - prefixes= - else - if $posix_mkdir; then - (umask=$mkdir_umask && - $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break - # Don't fail if two instances are running concurrently. - test -d "$prefix" || exit 1 - else - case $prefix in - *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; - *) qprefix=$prefix;; - esac - prefixes="$prefixes '$qprefix'" - fi - fi - prefix=$prefix/ + test X"$d" = X && continue + + prefix=$prefix$d + if test -d "$prefix"; then + prefixes= + else + if $posix_mkdir; then + (umask $mkdir_umask && + $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break + # Don't fail if two instances are running concurrently. + test -d "$prefix" || exit 1 + else + case $prefix in + *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; + *) qprefix=$prefix;; + esac + prefixes="$prefixes '$qprefix'" + fi + fi + prefix=$prefix/ done if test -n "$prefixes"; then - # Don't fail if two instances are running concurrently. - (umask $mkdir_umask && - eval "\$doit_exec \$mkdirprog $prefixes") || - test -d "$dstdir" || exit 1 - obsolete_mkdir_used=true + # Don't fail if two instances are running concurrently. + (umask $mkdir_umask && + eval "\$doit_exec \$mkdirprog $prefixes") || + test -d "$dstdir" || exit 1 + obsolete_mkdir_used=true fi fi fi @@ -451,14 +433,25 @@ do else # Make a couple of temp file names in the proper directory. - dsttmp=$dstdir/_inst.$$_ - rmtmp=$dstdir/_rm.$$_ + dsttmp=${dstdirslash}_inst.$$_ + rmtmp=${dstdirslash}_rm.$$_ # Trap to clean up those temp files at exit. trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 # Copy the file name to the temp name. - (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") && + (umask $cp_umask && + { test -z "$stripcmd" || { + # Create $dsttmp read-write so that cp doesn't create it read-only, + # which would cause strip to fail. + if test -z "$doit"; then + : >"$dsttmp" # No need to fork-exec 'touch'. + else + $doit touch "$dsttmp" + fi + } + } && + $doit_exec $cpprog "$src" "$dsttmp") && # and set any options; do chmod last to preserve setuid bits. # @@ -473,15 +466,12 @@ do # If -C, don't bother to copy if it wouldn't change the file. if $copy_on_change && - old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && - new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && - - eval "$initialize_posix_glob" && - $posix_glob set -f && + old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && + new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && + set -f && set X $old && old=:$2:$4:$5:$6 && set X $new && new=:$2:$4:$5:$6 && - $posix_glob set +f && - + set +f && test "$old" = "$new" && $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 then @@ -494,24 +484,24 @@ do # to itself, or perhaps because mv is so ancient that it does not # support -f. { - # Now remove or move aside any old file at destination location. - # We try this two ways since rm can't unlink itself on some - # systems and the destination file might be busy for other - # reasons. In this case, the final cleanup might fail but the new - # file should still install successfully. - { - test ! -f "$dst" || - $doit $rmcmd -f "$dst" 2>/dev/null || - { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && - { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } - } || - { echo "$0: cannot unlink or rename $dst" >&2 - (exit 1); exit 1 - } - } && - - # Now rename the file to the real destination. - $doit $mvcmd "$dsttmp" "$dst" + # Now remove or move aside any old file at destination location. + # We try this two ways since rm can't unlink itself on some + # systems and the destination file might be busy for other + # reasons. In this case, the final cleanup might fail but the new + # file should still install successfully. + { + test ! -f "$dst" || + $doit $rmcmd -f "$dst" 2>/dev/null || + { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && + { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } + } || + { echo "$0: cannot unlink or rename $dst" >&2 + (exit 1); exit 1 + } + } && + + # Now rename the file to the real destination. + $doit $mvcmd "$dsttmp" "$dst" } fi || exit 1 @@ -520,9 +510,9 @@ do done # Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) +# eval: (add-hook 'before-save-hook 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" -# time-stamp-time-zone: "UTC" +# time-stamp-time-zone: "UTC0" # time-stamp-end: "; # UTC" -# End: +# End:
\ No newline at end of file diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 056cf1f..9f68967 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -966,7 +966,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CFLAGS_DEBUG=-g AS_IF([test "$GCC" = yes], [ CFLAGS_OPTIMIZE=-O2 - CFLAGS_WARNING="-Wall -Wextra -Wwrite-strings -Wpointer-arith" + CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith" case "${CC}" in *++|*++-*) ;; @@ -2132,7 +2132,7 @@ AC_DEFUN([SC_TIME_HANDLER], [ fi AC_CACHE_CHECK([tm_gmtoff in struct tm], tcl_cv_member_tm_gmtoff, [ - AC_TRY_COMPILE([#include <time.h>], [struct tm tm; tm.tm_gmtoff;], + AC_TRY_COMPILE([#include <time.h>], [struct tm tm; (void)tm.tm_gmtoff;], tcl_cv_member_tm_gmtoff=yes, tcl_cv_member_tm_gmtoff=no)]) if test $tcl_cv_member_tm_gmtoff = yes ; then AC_DEFINE(HAVE_TM_GMTOFF, 1, [Should we use the tm_gmtoff field of struct tm?]) @@ -2445,14 +2445,14 @@ AC_DEFUN([SC_TCL_64BIT_FLAGS], [ AC_DEFUN([SC_TCL_CFG_ENCODING], [ AC_ARG_WITH(encoding, AC_HELP_STRING([--with-encoding], - [encoding for configuration values (default: iso8859-1)]), + [encoding for configuration values (default: utf-8)]), with_tcencoding=${withval}) if test x"${with_tcencoding}" != x ; then AC_DEFINE_UNQUOTED(TCL_CFGVAL_ENCODING,"${with_tcencoding}", [What encoding should be used for embedded configuration info?]) else - AC_DEFINE(TCL_CFGVAL_ENCODING,"iso8859-1", + AC_DEFINE(TCL_CFGVAL_ENCODING,"utf-8", [What encoding should be used for embedded configuration info?]) fi ]) diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c index e95d269..ee13350 100644 --- a/unix/tclLoadDyld.c +++ b/unix/tclLoadDyld.c @@ -292,8 +292,9 @@ TclpDlopen( *loadHandle = newHandle; result = TCL_OK; } else { - Tcl_Obj *errObj = Tcl_NewObj(); + Tcl_Obj *errObj; + TclNewObj(errObj); if (errMsg != NULL) { Tcl_AppendToObj(errObj, errMsg, -1); } diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index f670349..9273b8e 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -283,7 +283,7 @@ FileInputProc( */ bytesRead = read(fsPtr->fd, buf, (size_t) toRead); - if (bytesRead > -1) { + if (bytesRead >= 0) { return bytesRead; } *errorCodePtr = errno; @@ -330,7 +330,7 @@ FileOutputProc( return 0; } written = write(fsPtr->fd, buf, (size_t) toWrite); - if (written > -1) { + if (written >= 0) { return written; } *errorCodePtr = errno; diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index b188f21..eee47d7 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -1363,7 +1363,7 @@ GetGroupAttribute( groupPtr = TclpGetGrGid(statBuf.st_gid); if (groupPtr == NULL) { - *attributePtrPtr = Tcl_NewWideIntObj(statBuf.st_gid); + TclNewIntObj(*attributePtrPtr, statBuf.st_gid); } else { Tcl_DString ds; const char *utf; @@ -1417,7 +1417,7 @@ GetOwnerAttribute( pwPtr = TclpGetPwUid(statBuf.st_uid); if (pwPtr == NULL) { - *attributePtrPtr = Tcl_NewWideIntObj(statBuf.st_uid); + TclNewIntObj(*attributePtrPtr, statBuf.st_uid); } else { Tcl_DString ds; @@ -2411,7 +2411,7 @@ GetUnixFileAttributes( return TCL_ERROR; } - *attributePtrPtr = Tcl_NewWideIntObj( + TclNewIntObj(*attributePtrPtr, (fileAttributes & attributeArray[objIndex]) != 0); return TCL_OK; } @@ -2511,7 +2511,7 @@ GetUnixFileAttributes( return TCL_ERROR; } - *attributePtrPtr = Tcl_NewWideIntObj((statBuf.st_flags & UF_IMMUTABLE) != 0); + TclNewIntObj(*attributePtrPtr, (statBuf.st_flags & UF_IMMUTABLE) != 0); return TCL_OK; } diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index b67d91d..12cbd2c 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -463,7 +463,7 @@ TclpInitLibraryPath( const char *str; Tcl_DString buffer; - pathPtr = Tcl_NewObj(); + TclNewObj(pathPtr); /* * Look for the library relative to the TCL_LIBRARY env variable. If the diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 681ee64..5d02486 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -229,9 +229,10 @@ TclpCreateTempFile( Tcl_Obj * TclpTempFileName(void) { - Tcl_Obj *retVal, *nameObj = Tcl_NewObj(); + Tcl_Obj *retVal, *nameObj; int fd; + TclNewObj(nameObj); Tcl_IncrRefCount(nameObj); fd = TclUnixOpenTemporaryFile(NULL, NULL, NULL, nameObj); if (fd == -1) { @@ -1284,7 +1285,7 @@ Tcl_PidObjCmd( */ pipePtr = (PipeState *)Tcl_GetChannelInstanceData(chan); - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); for (i = 0; i < pipePtr->numPids; i++) { Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewWideIntObj(PTR2INT(TclpGetPid(pipePtr->pidPtr[i])))); diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index cb20166..8c9386c 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -233,7 +233,7 @@ InitializeHostName( struct hostent *hp; memset(&u, (int) 0, sizeof(struct utsname)); - if (uname(&u) > -1) { /* INTL: Native. */ + if (uname(&u) >= 0) { /* INTL: Native. */ hp = TclpGetHostByName(u.nodename); /* INTL: Native. */ if (hp == NULL) { /* @@ -281,7 +281,7 @@ InitializeHostName( char buffer[256]; # endif - if (gethostname(buffer, sizeof(buffer)) > -1) { /* INTL: Native. */ + if (gethostname(buffer, sizeof(buffer)) >= 0) { /* INTL: Native. */ native = buffer; } #endif /* NO_UNAME */ @@ -545,7 +545,7 @@ TcpInputProc( return -1; } bytesRead = recv(statePtr->fds.fd, buf, (size_t) bufSize, 0); - if (bytesRead > -1) { + if (bytesRead >= 0) { return bytesRead; } if (errno == ECONNRESET) { @@ -596,7 +596,7 @@ TcpOutputProc( } written = send(statePtr->fds.fd, buf, (size_t) toWrite, 0); - if (written > -1) { + if (written >= 0) { return written; } *errorCodePtr = errno; diff --git a/win/Makefile.in b/win/Makefile.in index 7c5c1bc..9757c2e 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -875,8 +875,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done; - @echo "Installing package http 2.9.3 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.3.tm"; + @echo "Installing package http 2.10.0a1 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.10.0a1.tm"; @echo "Installing package opt 0.4.7"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ diff --git a/win/configure b/win/configure index f099510..5888332 100755 --- a/win/configure +++ b/win/configure @@ -3749,8 +3749,7 @@ fi _ACEOF else - # Default encoding on windows is not "iso8859-1" - $as_echo "#define TCL_CFGVAL_ENCODING \"cp1252\"" >>confdefs.h + $as_echo "#define TCL_CFGVAL_ENCODING \"utf-8\"" >>confdefs.h fi @@ -4216,7 +4215,7 @@ $as_echo "using shared flags" >&6; } CFLAGS_DEBUG=-g CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" - CFLAGS_WARNING="-Wall -Wextra -Wwrite-strings -Wpointer-arith" + CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith" LDFLAGS_DEBUG= LDFLAGS_OPTIMIZE= diff --git a/win/makefile.vc b/win/makefile.vc index e3de98e..a28d6bf 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -114,10 +114,6 @@ # TESTPAT=<file>
# Reads the tests requested to be run from this file.
#
-# CFG_ENCODING=encoding
-# name of encoding for configuration information. Defaults
-# to cp1252
-#
# Examples:
# c:\tcl_src\win\>nmake -f makefile.vc release
# c:\tcl_src\win\>nmake -f makefile.vc test
diff --git a/win/nmakehlp.c b/win/nmakehlp.c index fac32ee..7536ede 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -708,7 +708,7 @@ QualifyPath( { char szCwd[MAX_PATH + 1]; - GetFullPathName(szPath, sizeof(szCwd)-1, szCwd, NULL); + GetFullPathName(szPath, sizeof(szCwd)-1, szCwd, NULL); printf("%s\n", szCwd); return 0; } diff --git a/win/rules.vc b/win/rules.vc index a4aeca1..f3e5439 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -415,9 +415,6 @@ _INSTALLDIR=$(_INSTALLDIR)\lib # NATIVE_ARCH - set to IX86 or AMD64 for the host machine
# MACHINE - same as $(ARCH) - legacy
# _VC_MANIFEST_EMBED_{DLL,EXE} - commands for embedding a manifest if needed
-# CFG_ENCODING - set to an character encoding.
-# TBD - this is passed to compiler as TCL_CFGVAL_ENCODING but can't
-# see where it is used
cc32 = $(CC) # built-in default.
link32 = link
@@ -503,10 +500,6 @@ _VC_MANIFEST_EMBED_EXE=if exist $@.manifest mt -nologo -manifest $@.manifest -ou _VC_MANIFEST_EMBED_DLL=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2
!endif
-!ifndef CFG_ENCODING
-CFG_ENCODING = \"cp1252\"
-!endif
-
################################################################
# 4. Build the nmakehlp program
# This is a helper app we need to overcome nmake's limiting
@@ -514,7 +507,7 @@ CFG_ENCODING = \"cp1252\" # information about supported compiler options etc.
#
# Tcl itself will always use the nmakehlp.c program which is
-# in its own source. This is the "master" copy and kept updated.
+# in its own source. It will be kept updated there.
#
# Extensions built against an installed Tcl will use the installed
# copy of Tcl's nmakehlp.c if there is one and their own version
@@ -1292,7 +1285,7 @@ INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\..\include # baselibs - minimum Windows libraries required. Parent makefile can
# define PRJ_LIBS before including rules.rc if additional libs are needed
-OPTDEFINES = /DTCL_CFGVAL_ENCODING=$(CFG_ENCODING) /DSTDC_HEADERS
+OPTDEFINES = /DSTDC_HEADERS
!if $(VCVERSION) >= 1600
OPTDEFINES = $(OPTDEFINES) /DHAVE_STDINT_H=1
!else
@@ -1669,7 +1662,7 @@ default-shell: default-setup $(PROJECT) !ifdef RCFILE
# Note: don't use $** in below rule because there may be other dependencies
-# and only the "master" rc must be passed to the resource compiler
+# and only the "main" rc must be passed to the resource compiler
$(TMP_DIR)\$(PROJECT).res: $(RCDIR)\$(PROJECT).rc
$(RESCMD) $(RCDIR)\$(PROJECT).rc
@@ -1723,7 +1716,7 @@ DISABLE_IMPLICIT_RULES = 0 !if !$(DISABLE_IMPLICIT_RULES)
# Implicit rule definitions - only for building library objects. For stubs and
-# main application, the master makefile should define explicit rules.
+# main application, the makefile should define explicit rules.
{$(ROOT)}.c{$(TMP_DIR)}.obj::
$(CCPKGCMD) @<<
@@ -673,7 +673,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CFLAGS_DEBUG=-g CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" - CFLAGS_WARNING="-Wall -Wextra -Wwrite-strings -Wpointer-arith" + CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith" LDFLAGS_DEBUG= LDFLAGS_OPTIMIZE= @@ -1085,8 +1085,7 @@ AC_DEFUN([SC_TCL_CFG_ENCODING], [ if test x"${with_tcencoding}" != x ; then AC_DEFINE_UNQUOTED(TCL_CFGVAL_ENCODING,"${with_tcencoding}") else - # Default encoding on windows is not "iso8859-1" - AC_DEFINE(TCL_CFGVAL_ENCODING,"cp1252") + AC_DEFINE(TCL_CFGVAL_ENCODING,"utf-8") fi ]) diff --git a/win/tclAppInit.c b/win/tclAppInit.c index 59c21e5..de5f788 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -29,7 +29,7 @@ extern Tcl_PackageInitProc Tcltest_Init; extern Tcl_PackageInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ -#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES +#if defined(STATIC_BUILD) && defined(TCL_USE_STATIC_PACKAGES) && TCL_USE_STATIC_PACKAGES extern Tcl_PackageInitProc Registry_Init; extern Tcl_PackageInitProc Dde_Init; extern Tcl_PackageInitProc Dde_SafeInit; @@ -164,7 +164,7 @@ Tcl_AppInit( return TCL_ERROR; } -#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES +#if defined(STATIC_BUILD) && defined(TCL_USE_STATIC_PACKAGES) && TCL_USE_STATIC_PACKAGES if (Registry_Init(interp) == TCL_ERROR) { return TCL_ERROR; } diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 6750d29..ad4bae1 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -1560,7 +1560,7 @@ GetWinFileAttributes( } } - *attributePtrPtr = Tcl_NewWideIntObj(attr != 0); + TclNewIntObj(*attributePtrPtr, attr != 0); return TCL_OK; } @@ -1926,7 +1926,7 @@ TclpObjListVolumes(void) int i; char *p; - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); /* * On Win32s: diff --git a/win/tclWinFile.c b/win/tclWinFile.c index d2777d7..89f485a 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1094,7 +1094,6 @@ TclpMatchInDirectory( do { const char *utfname; int checkDrive = 0, isDrive; - DWORD attr; native = data.cFileName; attr = data.dwFileAttributes; @@ -1445,7 +1444,6 @@ TclpGetUserHome( int rc = 0; const char *domain; WCHAR *wName, *wHomeDir, *wDomain; - WCHAR buf[MAX_PATH]; Tcl_DStringInit(bufferPtr); @@ -1511,6 +1509,7 @@ TclpGetUserHome( size = lstrlenW(wHomeDir); Tcl_WCharToUtfDString(wHomeDir, size, bufferPtr); } else { + WCHAR buf[MAX_PATH]; /* * User exists but has no home dir. Return * "{GetProfilesDirectory}/<user>". @@ -2818,7 +2817,6 @@ TclpObjNormalizePath( */ int len; - char *path; Tcl_Obj *tmpPathPtr; tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 420e324..5c3901b 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -189,7 +189,7 @@ TclpInitLibraryPath( const char *bytes; int length; - pathPtr = Tcl_NewObj(); + TclNewObj(pathPtr); /* * Initialize the substring used when locating the script library. The diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 14270f8..a93688d 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -2771,7 +2771,7 @@ Tcl_PidObjCmd( } pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan); - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); for (i = 0; i < pipePtr->numPids; i++) { Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr, Tcl_NewWideIntObj((unsigned) diff --git a/win/tclWinPort.h b/win/tclWinPort.h index bf4553c..d0b689f 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -18,6 +18,10 @@ /* See [Bug 3354324]: file mtime sets wrong time */ # define __MINGW_USE_VC2005_COMPAT #endif +#if !defined(__USE_MINGW_ANSI_STDIO) +/* See [Bug c975939973]: Usage of gnu_printf in latest mingw-w64 */ +# define __USE_MINGW_ANSI_STDIO 0 +#endif #if defined(_MSC_VER) && defined(_WIN64) && !defined(STATIC_BUILD) \ && !defined(MP_32BIT) && !defined(MP_64BIT) # define MP_64BIT @@ -297,7 +301,7 @@ typedef DWORD_PTR * PDWORD_PTR; * defined in header files above. */ -#if TCL_UNION_WAIT +#ifdef TCL_UNION_WAIT # define WAIT_STATUS_TYPE union wait #else # define WAIT_STATUS_TYPE int @@ -439,10 +443,10 @@ typedef DWORD_PTR * PDWORD_PTR; * Define pid_t and uid_t if they're not already defined. */ -#if ! TCL_PID_T +#if !defined(TCL_PID_T) # define pid_t int #endif /* !TCL_PID_T */ -#if ! TCL_UID_T +#if !defined(TCL_UID_T) # define uid_t int #endif /* !TCL_UID_T */ diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 328fbad..f0035b9 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1826,7 +1826,7 @@ SerialSetOptionProc( */ if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) { - int i, result = TCL_OK; + int i, res = TCL_OK; if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; @@ -1844,7 +1844,7 @@ SerialSetOptionProc( for (i = 0; i < argc - 1; i += 2) { if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) { - result = TCL_ERROR; + res = TCL_ERROR; break; } if (strncasecmp(argv[i], "DTR", strlen(argv[i])) == 0) { @@ -1856,7 +1856,7 @@ SerialSetOptionProc( Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } - result = TCL_ERROR; + res = TCL_ERROR; break; } } else if (strncasecmp(argv[i], "RTS", strlen(argv[i])) == 0) { @@ -1868,7 +1868,7 @@ SerialSetOptionProc( Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } - result = TCL_ERROR; + res = TCL_ERROR; break; } } else if (strncasecmp(argv[i], "BREAK", strlen(argv[i])) == 0) { @@ -1880,7 +1880,7 @@ SerialSetOptionProc( Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } - result = TCL_ERROR; + res = TCL_ERROR; break; } } else { @@ -1891,13 +1891,13 @@ SerialSetOptionProc( Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTY_SIGNAL", NULL); } - result = TCL_ERROR; + res = TCL_ERROR; break; } } ckfree(argv); - return result; + return res; } /* |