Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Merge trunk |
|---|---|
| Timelines: | family | ancestors | descendants | both | rfe-854941 | tip-596 |
| Files: | files | file ages | folders |
| SHA3-256: |
51c350e0e96def620bf7d3416f03fd44 |
| User & Date: | jan.nijtmans 2020-09-15 15:11:20.660 |
Context
|
2020-09-17
| ||
| 09:35 | Merge trunk check-in: 76b040cd6d user: jan.nijtmans tags: rfe-854941, tip-596 | |
|
2020-09-15
| ||
| 15:11 | Merge trunk check-in: 51c350e0e9 user: jan.nijtmans tags: rfe-854941, tip-596 | |
| 15:07 | Merge 8.7 check-in: ce41b9c9c1 user: jan.nijtmans tags: trunk | |
|
2020-08-19
| ||
| 12:57 | Merge trunk check-in: 11e411820b user: jan.nijtmans tags: rfe-854941, tip-596 | |
Changes
Changes to .fossil-settings/binary-glob.
|
| < < < < < < < < < < < < < < < < < | 1 2 3 4 5 6 7 | *.a *.bmp *.dll *.exe *.gif *.gz *.jpg |
| ︙ | ︙ |
Changes to .fossil-settings/ignore-glob.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 | html libtommath/bn.ilg libtommath/bn.ind libtommath/pretty.build libtommath/tommath.src libtommath/*.log libtommath/*.pdf | | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | html libtommath/bn.ilg libtommath/bn.ind libtommath/pretty.build libtommath/tommath.src libtommath/*.log libtommath/*.pdf libtommath/*.pl libtommath/*.sh libtommath/doc/* libtommath/tombc/* libtommath/pre_gen/* libtommath/pics/* libtommath/mtest/* libtommath/logs/* |
| ︙ | ︙ | |||
60 61 62 63 64 65 66 67 | unix/pkgs/* win/Debug* win/Release* win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj win/nmhlp-out.txt | > | 60 61 62 63 64 65 66 67 68 | unix/pkgs/* win/Debug* win/Release* win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj win/nmakehlp.out win/nmhlp-out.txt |
Changes to .gitattributes.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 36 | # Declare files that will always have CRLF line endings on checkout. *.bat eol=crlf *.sln eol=crlf *.vc eol=crlf # Denote all files that are truly binary and should not be modified. *.a binary *.dll binary *.exe binary *.gif binary *.gz binary *.jpg binary *.lib binary *.pdf binary | > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | # Declare files that will always have CRLF line endings on checkout. *.bat eol=crlf *.sln eol=crlf *.vc eol=crlf # Denote all files that are truly binary and should not be modified. *.a binary *.bmp binary *.dll binary *.exe binary *.gif binary *.gz binary *.jpg binary *.lib binary *.pdf binary |
| ︙ | ︙ |
Changes to .travis.yml.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 |
- gcc-mingw-w64-x86-64
- gcc-multilib
jobs:
include:
# Testing on Linux with various compilers
- name: "Linux/GCC/Shared"
os: linux
| | | | | | | | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
- gcc-mingw-w64-x86-64
- gcc-multilib
jobs:
include:
# Testing on Linux with various compilers
- name: "Linux/GCC/Shared"
os: linux
dist: focal
compiler: gcc
env:
- BUILD_DIR=unix
- name: "Linux/GCC/Shared: UTF_MAX=3"
os: linux
dist: focal
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT="CFLAGS=-DTCL_UTF_MAX=3"
- name: "Linux/GCC/Shared: NO_DEPRECATED"
os: linux
dist: focal
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1"
- name: "Linux/GCC/Static"
os: linux
dist: focal
compiler: gcc
env:
- CFGOPT="--disable-shared"
- BUILD_DIR=unix
- name: "Linux/GCC/Debug"
os: linux
dist: focal
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols"
- name: "Linux/GCC/Mem-Debug"
os: linux
dist: focal
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols=mem"
# C++ build.
- name: "Linux/G++/Shared"
os: linux
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"
os: linux
dist: focal
compiler: gcc-7
addons:
apt:
sources:
- ubuntu-toolchain-r-test
packages:
- g++-7
|
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
packages:
- g++-5
env:
- BUILD_DIR=unix
# Clang
- name: "Linux/Clang/Shared"
os: linux
| | | | | | | | | | | | | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 |
packages:
- g++-5
env:
- BUILD_DIR=unix
# Clang
- name: "Linux/Clang/Shared"
os: linux
dist: focal
compiler: clang
env:
- BUILD_DIR=unix
- name: "Linux/Clang/Static"
os: linux
dist: focal
compiler: clang
env:
- CFGOPT="--disable-shared"
- BUILD_DIR=unix
- name: "Linux/Clang/Debug"
os: linux
dist: focal
compiler: clang
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols"
- name: "Linux/Clang/Mem-Debug"
os: linux
dist: focal
compiler: clang
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols=mem"
# Testing on Mac, various styles
- name: "macOS/Clang/Xcode 11.7/Shared"
os: osx
osx_image: xcode11.7
env:
- BUILD_DIR=macosx
install: []
script: &mactest
- make all
# The styles=develop avoids some weird problems on OSX
- make test styles=develop
- name: "macOS/Clang/Xcode 11.7/Shared/Unix-like"
os: osx
osx_image: xcode11.7
env:
- BUILD_DIR=unix
- name: "macOS/Clang/Xcode 11.7/Shared/libtommath"
os: osx
osx_image: xcode11.7
env:
- BUILD_DIR=macosx
install: []
script: *mactest
addons:
homebrew:
packages:
- libtommath
- name: "macOS/Clang++/Xcode 11.7/Shared"
os: osx
osx_image: xcode11.7
env:
- BUILD_DIR=unix
- CFGOPT="CC=clang++ --enable-framework CFLAGS=-Dregister=dont+use+register CPPFLAGS=-D__private_extern__=extern"
script:
- make all tcltest
# Older MacOS versions
- name: "macOS/Clang/Xcode 11/Shared"
|
| ︙ | ︙ | |||
190 191 192 193 194 195 196 |
- BUILD_DIR=macosx
install: []
script: *mactest
# Test with mingw-w64 cross-compile
# Doesn't run tests because wine is only an imperfect Windows emulation
- name: "Linux-cross-Windows/GCC/Shared/no test"
os: linux
| | | | 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 |
- BUILD_DIR=macosx
install: []
script: *mactest
# Test with mingw-w64 cross-compile
# Doesn't run tests because wine is only an imperfect Windows emulation
- name: "Linux-cross-Windows/GCC/Shared/no test"
os: linux
dist: focal
compiler: x86_64-w64-mingw32-gcc
env:
- BUILD_DIR=win
- CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit"
script: &crosstest
- make all tcltest
# Include a high visibility marker that tests are skipped outright
- >
echo "`tput setaf 3`SKIPPED TEST: CROSS COMPILING`tput sgr0`"
# Test with mingw-w64 (32 bit) cross-compile
# Doesn't run tests because wine is only an imperfect Windows emulation
- name: "Linux-cross-Windows-32/GCC/Shared/no test"
os: linux
dist: focal
compiler: i686-w64-mingw32-gcc
env:
- BUILD_DIR=win
- CFGOPT=--host=i686-w64-mingw32
script: *crosstest
# Test on Windows with MSVC native
- name: "Windows/MSVC/Shared"
|
| ︙ | ︙ | |||
414 415 416 417 418 419 420 |
env:
- BUILD_DIR=win
- CFGOPT="--enable-symbols=mem"
before_install: *makepreinst
# "make dist" only
- name: "Linux: make dist"
os: linux
| | | 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 |
env:
- BUILD_DIR=win
- CFGOPT="--enable-symbols=mem"
before_install: *makepreinst
# "make dist" only
- name: "Linux: make dist"
os: linux
dist: focal
compiler: gcc
env:
- BUILD_DIR=unix
script:
- make dist
before_install:
- cd ${BUILD_DIR}
|
| ︙ | ︙ |
Changes to doc/CrtAlias.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_CreateAlias 3 7.6 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH Tcl_CreateAlias 3 7.6 Tcl "Tcl Library Procedures"
.so man.macros
.BS
.SH NAME
Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateChild, Tcl_GetChild, Tcl_GetParent, 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
.sp
int
\fBTcl_IsSafe\fR(\fIinterp\fR)
.sp
int
\fBTcl_MakeSafe\fR(\fIinterp\fR)
.sp
Tcl_Interp *
\fBTcl_CreateChild\fR(\fIinterp, name, isSafe\fR)
.sp
Tcl_Interp *
\fBTcl_GetChild\fR(\fIinterp, name\fR)
.sp
Tcl_Interp *
\fBTcl_GetParent\fR(\fIinterp\fR)
.sp
int
\fBTcl_GetInterpPath\fR(\fIinterp, childInterp\fR)
.sp
int
\fBTcl_CreateAlias\fR(\fIchildInterp, childCmd, targetInterp, targetCmd,
argc, argv\fR)
.sp
int
\fBTcl_CreateAliasObj\fR(\fIchildInterp, childCmd, targetInterp, targetCmd,
objc, objv\fR)
.sp
int
\fBTcl_GetAlias\fR(\fIinterp, childCmd, targetInterpPtr, targetCmdPtr,
argcPtr, argvPtr\fR)
.sp
int
\fBTcl_GetAliasObj\fR(\fIinterp, childCmd, targetInterpPtr, targetCmdPtr,
objcPtr, objvPtr\fR)
.sp
int
\fBTcl_ExposeCommand\fR(\fIinterp, hiddenCmdName, cmdName\fR)
.sp
int
\fBTcl_HideCommand\fR(\fIinterp, cmdName, hiddenCmdName\fR)
.SH ARGUMENTS
.AS "const char *const" **targetInterpPtr out
.AP Tcl_Interp *interp in
Interpreter in which to execute the specified command.
.AP "const char" *name in
Name of child interpreter to create or manipulate.
.AP int isSafe in
If non-zero, a
.QW safe
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" *childCmd in
Name of source command for alias.
.AP Tcl_Interp *targetInterp in
Interpreter that contains the target command for an alias.
.AP "const char" *targetCmd in
Name of target command for alias in \fItargetInterp\fR.
.AP int argc in
Count of additional arguments to pass to the alias command.
|
| ︙ | ︙ | |||
117 118 119 120 121 122 123 | facility from inside C programs. They enable managing multiple interpreters in a hierarchical relationship, and the management of aliases, commands that when invoked in one interpreter execute a command in another 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 | | | | | | | | | | | | | | | | | | | | | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 | facility from inside C programs. They enable managing multiple interpreters in a hierarchical relationship, and the management of aliases, commands that when invoked in one interpreter execute a command in another 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_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 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 child interpreter failed, \fBNULL\fR is returned. .PP \fBTcl_IsSafe\fR returns \fB1\fR if \fIinterp\fR is .QW safe (was created with the \fBTCL_SAFE_INTERPRETER\fR flag specified), \fB0\fR otherwise. .PP \fBTcl_MakeSafe\fR marks \fIinterp\fR as .QW safe , so that future calls to \fBTcl_IsSafe\fR will return 1. It also removes all known potentially-unsafe core functionality (both commands and variables) 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_CreateChild\fR may be a better choice, since it creates interpreters in a known-safe state. .PP \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_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_GetInterpPath\fR stores in the result of \fIinterp\fR 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 \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 \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 \fIchildInterp\fR. Note that there are no restrictions on the ancestry relationship (as 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 \fBTcl_CreateAliasObj\fR is similar to \fBTcl_CreateAlias\fR except that it takes a vector of values to pass as additional arguments instead of a vector of strings. .PP |
| ︙ | ︙ | |||
229 230 231 232 233 234 235 | For a description of the Tcl interface to multiple interpreters, see \fIinterp(n)\fR. .SH "SEE ALSO" interp .SH KEYWORDS alias, command, exposed commands, hidden commands, interpreter, invoke, | | | 229 230 231 232 233 234 235 236 | For a description of the Tcl interface to multiple interpreters, see \fIinterp(n)\fR. .SH "SEE ALSO" interp .SH KEYWORDS alias, command, exposed commands, hidden commands, interpreter, invoke, parent, child |
Changes to doc/FileSystem.3.
| ︙ | ︙ | |||
1336 1337 1338 1339 1340 1341 1342 | .PP The result should be a list of volumes added by this filesystem, or NULL (or an empty list) if no volumes are provided. The result value 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 | | | | 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 | .PP The result should be a list of volumes added by this filesystem, or NULL (or an empty list) if no volumes are provided. The result value 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 "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 global list and pass it to Tcl which will copy the contents and then decrement the count back to where it was). .PP Therefore, Tcl considers return values from this proc to be read-only. .SS FILEATTRSTRINGSPROC .PP Function to list all attribute strings which are valid for this |
| ︙ | ︙ |
Changes to doc/GetIndex.3.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 | .SH ARGUMENTS .AS "const char" *structTablePtr in/out .AP Tcl_Interp *interp in 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. | > | > | > | | > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | .SH ARGUMENTS .AS "const char" *structTablePtr in/out .AP Tcl_Interp *interp in 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. 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, 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, 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 The offset to add to structTablePtr to get to the next entry. The end of the array is marked by a NULL string pointer. .AP "const char" *msg in 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 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. .BE .SH DESCRIPTION .PP These procedures provide an efficient way for looking up keywords, |
| ︙ | ︙ | |||
72 73 74 75 76 77 78 | If there is no matching entry, \fBTCL_ERROR\fR is returned and an error message is left in \fIinterp\fR's result if \fIinterp\fR is not NULL. \fIMsg\fR is included in the 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 | > | > > | | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 | If there is no matching entry, \fBTCL_ERROR\fR is returned and an error message is left in \fIinterp\fR's result if \fIinterp\fR is not NULL. \fIMsg\fR is included in the 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 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 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. 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 \fBTcl_GetIndexFromObjStruct\fR works just like \fBTcl_GetIndexFromObj\fR, except that instead of treating \fItablePtr\fR as an array of string pointers, it treats it as a pointer to the first string in a series of strings that have |
| ︙ | ︙ |
Changes to doc/Limit.3.
| ︙ | ︙ | |||
112 113 114 115 116 117 118 | the interpreter to permit it to continue processing longer. .PP When a limit is exceeded (and the callbacks have run; the order of 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 | | | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 | the interpreter to permit it to continue processing longer. .PP When a limit is exceeded (and the callbacks have run; the order of 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 the main interpreter) to handle the error. .SH "LIMIT CHECKING API" .PP To check the resource limits for an interpreter, call \fBTcl_LimitCheck\fR, which returns \fBTCL_OK\fR if the limit was not exceeded (after processing callbacks) and \fBTCL_ERROR\fR if the limit was exceeded (in which case an error message is also placed in the interpreter result). That function should only be called when |
| ︙ | ︙ |
Changes to doc/Tcl_Main.3.
| ︙ | ︙ | |||
75 76 77 78 79 80 81 | .PP \fBTcl_Main\fR is not provided by the public interface of Tcl's stub library. Programs that call \fBTcl_Main\fR must be linked 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 | | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | .PP \fBTcl_Main\fR is not provided by the public interface of Tcl's stub library. Programs that call \fBTcl_Main\fR must be linked 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 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 \fBtclsh\fR, use \fBTcl_GetStdChannel\fR to initialize the standard channels to their default values. See \fBTcl_StandardChannels\fR for more information. .PP |
| ︙ | ︙ | |||
108 109 110 111 112 113 114 | and the stored encoding name is written to space pointed to by \fIencodingPtr\fR, when that is not NULL. .PP 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 | | | | 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 | and the stored encoding name is written to space pointed to by \fIencodingPtr\fR, when that is not NULL. .PP 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 main thread as \fBTcl_Main\fR can have any influence on it. .PP The caller of \fBTcl_Main\fR may call \fBTcl_SetStartupScript\fR first to establish its desired startup script. If \fBTcl_Main\fR finds that no such startup script has been established, it consults the first few arguments in \fIargv\fR. If they match ?\fB\-encoding \fIname\fR? \fIfileName\fR, where \fIfileName\fR does not begin with the character \fI\-\fR, then \fIfileName\fR is taken to be the name of a file containing 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 main interpreter the Tcl variables \fIargc\fR, \fIargv\fR, \fIargv0\fR, and \fItcl_interactive\fR, as described in the documentation for \fBtclsh\fR. .PP When it has finished its own initialization, but before it processes commands, \fBTcl_Main\fR calls the procedure given by the \fIappInitProc\fR argument. This procedure provides a .QW hook |
| ︙ | ︙ | |||
150 151 152 153 154 155 156 | details on this procedure, see the documentation for \fBTcl_AppInit\fR. .PP When the \fIappInitProc\fR is finished, \fBTcl_Main\fR calls \fBTcl_GetStartupScript\fR to determine what startup script has 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 | | | | | 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 | details on this procedure, see the documentation for \fBTcl_AppInit\fR. .PP When the \fIappInitProc\fR is finished, \fBTcl_Main\fR calls \fBTcl_GetStartupScript\fR to determine what startup script has 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 main interpreter. If that variable exists and holds the name of a readable file, the contents of that file are evaluated 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 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 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 loop. The event loop will run following the startup script. If you are in interactive mode, setting the main loop procedure will cause the prompt to become fileevent based and then the loop procedure is called. When the loop procedure returns in interactive mode, interactive operation |
| ︙ | ︙ |
Changes to doc/http.n.
| ︙ | ︙ | |||
255 256 257 258 259 260 261 262 263 264 265 266 267 268 |
...
set data [read $socket 1000]
set nbytes [string length $data]
...
return $nbytes
}
.CE
.RE
.TP
\fB\-headers\fR \fIkeyvaluelist\fR
.
This option is used to add headers not already specified
by \fB::http::config\fR to the HTTP request. The
\fIkeyvaluelist\fR argument must be a list with an even number of
| > > > > | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
...
set data [read $socket 1000]
set nbytes [string length $data]
...
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
.
This option is used to add headers not already specified
by \fB::http::config\fR to the HTTP request. The
\fIkeyvaluelist\fR argument must be a list with an even number of
|
| ︙ | ︙ |
Changes to doc/interp.n.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 | .SH SYNOPSIS \fBinterp \fIsubcommand \fR?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP This command makes it possible to create one or more new Tcl interpreters that co-exist with the creating interpreter in the | | | | | | | | | | | | | | | | | | | | | | | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 |
.SH SYNOPSIS
\fBinterp \fIsubcommand \fR?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.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 \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 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 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,
and by resource limit exceeded callbacks. Note that the
name space for files (such as the names returned by the \fBopen\fR command)
is no longer shared between interpreters. Explicit commands are provided to
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 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
commands and subprocess creation commands are made inaccessible to safe
interpreters.
See \fBSAFE INTERPRETERS\fR below for more information on
what features are present in a safe interpreter.
The dangerous functionality is not removed from the safe interpreter;
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 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
ancestors in the interpreter hierarchy, terminated by the string naming 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 child of the current interpreter and it has a child
.QW \fBa1\fR ,
which in turn has a child
.QW \fBa11\fR ,
the qualified name of
.QW \fBa11\fR
in
.QW \fBa\fR
is the list
.QW "\fBa1 a11\fR" .
.PP
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 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
child interpreters, and to share or transfer
channels between interpreters. It can have any of several forms, depending
on the \fIsubcommand\fR argument:
.TP
\fBinterp\fR \fBalias\fR \fIsrcPath\fR \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 name of the source command in the
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 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
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 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.
\fISrcPath\fR is a Tcl list whose elements select a particular
interpreter. For example,
.QW "\fBa b\fR"
identifies an interpreter
.QW \fBb\fR ,
which is a child of interpreter
.QW \fBa\fR ,
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
and command, and the \fIarg\fR arguments, if any, specify additional
arguments to \fItargetCmd\fR which are prepended to any arguments specified
in the invocation of \fIsrcCmd\fR.
\fITargetCmd\fR may be undefined at the time of this call, or it may
|
| ︙ | ︙ | |||
165 166 167 168 169 170 171 | switches; it may be needed if \fIpath\fR is an unusual value such as \fB\-safe\fR. If \fIresult\fR is present, it will be used as the error message string; otherwise, a default error message string will be used. .TP \fBinterp\fR \fBcreate \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? . | | | | | | | | | | | | | | | 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 | switches; it may be needed if \fIpath\fR is an unusual value such as \fB\-safe\fR. If \fIresult\fR is present, it will be used as the error message string; otherwise, a default error message string will be used. .TP \fBinterp\fR \fBcreate \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? . 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 child interpreter and child command named \fBc\fR are created in the interpreter identified by the path \fBa b\fR. 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 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 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 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 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. This only affects the output of \fBinfo frame\fR, in that exact frame-level information for command invocation at the bytecode level is only captured with this setting on. .RS |
| ︙ | ︙ | |||
233 234 235 236 237 238 239 | attempts are silently ignored. This is needed to maintain the consistency of the underlying interpreter's state. .RE .TP \fBinterp\fR \fBdelete \fR?\fIpath ...\fR? . Deletes zero or more interpreters given by the optional \fIpath\fR | | | | | | | | | | 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 | attempts are silently ignored. This is needed to maintain the consistency of the underlying interpreter's state. .RE .TP \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 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 \fBinterp\fR \fBeval\fR \fIpath arg \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 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 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 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? . Makes the hidden command \fIhiddenName\fR exposed, 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 ::), |
| ︙ | ︙ | |||
281 282 283 284 285 286 287 | by \fIpath\fR. 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 by \fBinterp hide\fR are looked up in the global namespace even if the current namespace is not the global one. This | | | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 | by \fIpath\fR. 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 by \fBinterp hide\fR are looked up in the global namespace even if the current namespace is not the global one. This 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 \fBinterp\fR \fBhidden\fR \fIpath\fR . Returns a list of the names of all hidden commands in the interpreter identified by \fIpath\fR. |
| ︙ | ︙ | |||
365 366 367 368 369 370 371 | between the interpreter identified by \fIsrcPath\fR and the interpreter identified by \fIdestPath\fR. Both interpreters have the same permissions on the IO channel. 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 | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 |
between the interpreter identified by \fIsrcPath\fR and the interpreter
identified by \fIdestPath\fR. Both interpreters have the same permissions
on the IO channel.
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 \fBchildren\fR ?\fIpath\fR?
.
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 \fBtarget\fR \fIpath alias\fR
.
Returns a Tcl list describing the target interpreter for an alias. The
alias is specified with an interpreter path and source command name, just
as in \fBinterp alias\fR above. The name of the target interpreter is
returned as an interpreter path, relative to the invoking interpreter.
If the target interpreter for the alias is the invoking interpreter then an
empty list is returned. If the target interpreter for the alias is not the
invoking interpreter or one of its descendants then an error is generated.
The target command does not have to be defined at the time of this invocation.
.TP
\fBinterp\fR \fBtransfer\fR \fIsrcPath channelId destPath\fR
.
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 "CHILD COMMAND"
.PP
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
\fIchild command \fR?\fIarg arg ...\fR?
.CE
.PP
\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
\fIchild \fBaliases\fR
.
Returns a Tcl list whose elements are the tokens of all the
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
\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
child is different from \fIsrcToken\fR).
.TP
\fIchild \fBalias \fIsrcToken \fB{}\fR
.
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
\fIchild \fBalias \fIsrcCmd targetCmd \fR?\fIarg ..\fR?
.
Creates an alias such that whenever \fIsrcCmd\fR is invoked
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.
See \fBALIAS INVOCATION\fR below for details.
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
\fIchild \fBbgerror\fR ?\fIcmdPrefix\fR?
.
This command either gets or sets the current background exception handler
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
\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 \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 \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
\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 \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
\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 \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 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
\fIchild \fBhidden\fR
.
Returns a list of the names of all hidden commands in \fIchild\fR.
.TP
\fIchild \fBinvokehidden\fR ?\fI\-option ...\fR? \fIhiddenName \fR?\fIarg ..\fR?
.
This command invokes the hidden command \fIhiddenName\fR with the
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 child.
If the \fB\-global\fR flag is given, the command is invoked at the global
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 \-
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 \fIchild\fR.
For more details on hidden commands,
see \fBHIDDEN COMMANDS\fR, below.
.TP
\fIchild \fBissafe\fR
.
Returns \fB1\fR if the child interpreter is safe, \fB0\fR otherwise.
.TP
\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 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
\fIchild \fBmarktrusted\fR
.
Marks the child interpreter as trusted. Can only be invoked by a
trusted interpreter. This command does not expose any hidden
commands in the child interpreter. The command has no effect if the child
is already trusted.
.TP
\fIchild\fR \fBrecursionlimit\fR ?\fInewlimit\fR?
.
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 \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.
.RS
.PP
The command sets the maximum size of the Tcl call stack only. It cannot
by itself prevent stack overflows on the C stack being used by the
|
| ︙ | ︙ | |||
561 562 563 564 565 566 567 | fear of that script damaging the enclosing application or the rest of your computing environment. In order to make an interpreter safe, certain commands and variables are removed from the interpreter. 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 | | | | 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 | fear of that script damaging the enclosing application or the rest of your computing environment. In order to make an interpreter safe, certain commands and variables are removed from the interpreter. 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 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 child created by a safe interpreter will also be safe. .PP A safe interpreter is created with exactly the following set of built-in commands: .DS .ta 1.2i 2.4i 3.6i \fBafter\fR \fBappend\fR \fBapply\fR \fBarray\fR |
| ︙ | ︙ | |||
655 656 657 658 659 660 661 | \fBSafe\-Tcl\fR and the \fBload\fR Tcl command. .PP A safe interpreter may not alter the recursion limit of any interpreter, including itself. .SH "ALIAS INVOCATION" .PP The alias mechanism has been carefully designed so that it can | | | | | | | | | | 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 | \fBSafe\-Tcl\fR and the \fBload\fR Tcl command. .PP A safe interpreter may not alter the recursion limit of any interpreter, including itself. .SH "ALIAS INVOCATION" .PP The alias mechanism has been carefully designed so that it can 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. The command procedure for the source command takes its arguments and merges them with the \fItargetCmd\fR and \fIarg\fRs for the alias to create a new array of arguments. If the words of \fIsrcCmd\fR were |
| ︙ | ︙ | |||
690 691 692 693 694 695 696 | \fItargetCmd\fR and \fIargs\fR were substituted when parsing the command that created the alias, and \fIarg1 - argN\fR are substituted when the alias's source command is parsed in the source interpreter. .PP 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 | | | | 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 | \fItargetCmd\fR and \fIargs\fR were substituted when parsing the command that created the alias, and \fIarg1 - argN\fR are substituted when the alias's source command is parsed in the source interpreter. .PP 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 child interpreter could execute arbitrary code in the parent. This in turn would compromise the security of the system. .SH "HIDDEN COMMANDS" .PP Safe interpreters greatly restrict the functionality available to Tcl programs executing within them. Allowing the untrusted Tcl program to have direct access to this functionality is unsafe, because it can be used for a variety of |
| ︙ | ︙ | |||
718 719 720 721 722 723 724 | unavailable to Tcl scripts executing in the interpreter. However, such hidden commands can be invoked by any trusted ancestor of the safe interpreter, in the context of the safe interpreter, using \fBinterp 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 | | | | | | | | | | | | | | | 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 | unavailable to Tcl scripts executing in the interpreter. However, such hidden commands can be invoked by any trusted ancestor of the safe interpreter, in the context of the safe interpreter, using \fBinterp 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 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 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 child interpreter: the alias, and the hidden command. .PP 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 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 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 interpreter using \fBinterp expose\fR and \fBinterp hide\fR. The \fBinterp expose\fR command moves a hidden command to the set of exposed commands in the interpreter identified by \fIpath\fR, potentially renaming the command in the process. If an exposed command by the targeted name already exists, the operation fails. Similarly, \fBinterp hide\fR moves an exposed command to the set of hidden commands in that interpreter. Safe interpreters are not allowed to move commands between the set of hidden and exposed commands, in either themselves or their descendants. .PP Currently, the names of hidden commands cannot contain namespace 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 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 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 interpreter must complete. Note that time limits are expressed as \fIabsolute\fR times (as in \fBclock seconds\fR) and not relative times (as in \fBafter\fR) because they may be modified after creation. .PP When a limit is exceeded for an interpreter, first any handler callbacks 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 command) is disabled, so the error propagates outwards (building a stack-trace as it goes) to the point where the limited interpreter was invoked (e.g. by \fBinterp eval\fR) where it becomes the responsibility of the calling code to catch and handle. |
| ︙ | ︙ | |||
829 830 831 832 833 834 835 | .TP \fB\-value\fR . 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 | | | | | | | 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 | .TP \fB\-value\fR . 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 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 parent as necessary. .SH "BACKGROUND EXCEPTION HANDLING" .PP When an exception happens in a situation where it cannot be reported directly up the stack (e.g. when processing events in an \fBupdate\fR or \fBvwait\fR call) the exception is instead reported through the background exception handling mechanism. Every interpreter has a background exception handler registered; the default exception |
| ︙ | ︙ | |||
896 897 898 899 900 901 902 |
set x 0
while {1} {
puts "Counting up... [incr x]"
}
}
.CE
.SH "SEE ALSO"
| | | | 896 897 898 899 900 901 902 903 904 905 906 907 908 |
set x 0
while {1} {
puts "Counting up... [incr x]"
}
}
.CE
.SH "SEE ALSO"
bgerror(n), load(n), safe(n), Tcl_CreateChild(3), Tcl_Eval(3), Tcl_BackgroundException(3)
.SH KEYWORDS
alias, parent interpreter, safe interpreter, child interpreter
'\"Local Variables:
'\"mode: nroff
'\"End:
|
Changes to doc/library.n.
| ︙ | ︙ | |||
120 121 122 123 124 125 126 | \fBauto_mkindex foo *.tcl\fR .CE .PP 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 | | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | \fBauto_mkindex foo *.tcl\fR .CE .PP 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 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 auto.tcl to see how this works. .PP \fBAuto_mkindex_old\fR (which has the same syntax as \fBauto_mkindex\fR) |
| ︙ | ︙ |
Changes to doc/pkgMkIndex.n.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 | script or binary files in \fIdir\fR. The default pattern is \fB*.tcl\fR and \fB*.[info sharedlibextension]\fR. .RS .PP \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. | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | script or binary files in \fIdir\fR. The default pattern is \fB*.tcl\fR and \fB*.[info sharedlibextension]\fR. .RS .PP \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 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 in the files, as described above). If you have a package split among scripts and binary files, or if you have dependencies among files, you may have to use the \fB\-load\fR option |
| ︙ | ︙ | |||
105 106 107 108 109 110 111 | The generated index will manage to delay loading the package until the use of one of the commands provided by the package, instead of loading it immediately upon \fBpackage require\fR. This is not compatible with 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 | | | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 | The generated index will manage to delay loading the package until the use of one of the commands provided by the package, instead of loading it immediately upon \fBpackage require\fR. This is not compatible with 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 child interpreter used to generate the index. The pattern match uses string match rules, but without making case distinctions. See \fBCOMPLEX CASES\fR below. .TP 15 \fB\-verbose\fR Generate output during the indexing process. Output is via the \fBtclLog\fR procedure, which by default prints to stderr. |
| ︙ | ︙ |
Changes to doc/safe.n.
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH "Safe Tcl" n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME safe \- Creating and manipulating safe interpreters .SH SYNOPSIS | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH "Safe Tcl" n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME safe \- Creating and manipulating safe interpreters .SH SYNOPSIS \fB::safe::interpCreate\fR ?\fIchild\fR? ?\fIoptions...\fR? .sp \fB::safe::interpInit\fR \fIchild\fR ?\fIoptions...\fR? .sp \fB::safe::interpConfigure\fR \fIchild\fR ?\fIoptions...\fR? .sp \fB::safe::interpDelete\fR \fIchild\fR .sp \fB::safe::interpAddToAccessPath\fR \fIchild\fR \fIdirectory\fR .sp \fB::safe::interpFindInAccessPath\fR \fIchild\fR \fIdirectory\fR .sp \fB::safe::setLogCmd\fR ?\fIcmd arg...\fR? .SS OPTIONS .PP ?\fB\-accessPath\fR \fIpathList\fR? ?\fB\-statics\fR \fIboolean\fR? ?\fB\-noStatics\fR? ?\fB\-nested\fR \fIboolean\fR? ?\fB\-nestedLoadOk\fR? |
| ︙ | ︙ | |||
40 41 42 43 44 45 46 | hosting application. It prevents integrity and privacy attacks. Untrusted Tcl scripts are prevented from corrupting the state of the hosting 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 | | | | | | | > > > > > > | | | > > | | | | | | | | | | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 |
hosting application.
It prevents integrity and privacy attacks. Untrusted Tcl
scripts are prevented from corrupting the state of the hosting
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 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.
.PP
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
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 parent interpreter by Safe Tcl reside in
the \fBsafe\fR namespace.
.SH COMMANDS
The following commands are provided in the parent interpreter:
.TP
\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 \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 \fIchild\fR ?\fIoptions...\fR?
This command is similar to \fBinterpCreate\fR except it that does not
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 \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 \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 \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.
Example of use:
.RS
.PP
.CS
# Create new interp with the same configuration as "$i0":
set i1 [safe::interpCreate {*}[safe::interpConfigure $i0]]
# Get the current deleteHook
set dh [safe::interpConfigure $i0 \-del]
# Change (only) the statics loading ok attribute of an
# interp and its deleteHook (leaving the rest unchanged):
safe::interpConfigure $i0 \-delete {foo bar} \-statics 0
.CE
.RE
.TP
\fB::safe::interpDelete\fR \fIchild\fR
Deletes the safe interpreter and cleans up the corresponding
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 \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.
Example of use:
.RS
.PP
.CS
$child eval [list set tk_library \e
[::safe::interpFindInAccessPath $name $tk_library]]
.CE
.RE
.TP
\fB::safe::interpAddToAccessPath\fR \fIchild\fR \fIdirectory\fR
This command adds \fIdirectory\fR to the virtual path maintained for the
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.
Example of use:
.RS
.PP
.CS
$child eval [list set tk_library \e
[::safe::interpAddToAccessPath $name $tk_library]]
.CE
.RE
.TP
\fB::safe::setLogCmd\fR ?\fIcmd arg...\fR?
This command installs a script that will be called when interesting
life cycle events occur for a safe interpreter.
|
| ︙ | ︙ | |||
164 165 166 167 168 169 170 | .PP Below is the output of a sample session in which a safe interpreter attempted to source a file not found in its virtual access path. Note that the safe interpreter only received an error message saying that the file was not found: .PP .CS | | | | | | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
.PP
Below is the output of a sample session in which a safe interpreter
attempted to source a file not found in its virtual access path.
Note that the safe interpreter only received an error message saying that
the file was not found:
.PP
.CS
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
The following options are common to
\fB::safe::interpCreate\fR, \fB::safe::interpInit\fR,
and \fB::safe::interpConfigure\fR.
Any option name can be abbreviated to its minimal
non-ambiguous name.
Option names are not case sensitive.
.TP
\fB\-accessPath\fR \fIdirectoryList\fR
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
parent for auto-loading.
See the section \fBSECURITY\fR below for more detail about virtual paths,
tokens and access control.
.TP
\fB\-statics\fR \fIboolean\fR
This option specifies if the safe interpreter will be allowed
to load statically linked packages (like \fBload {} Tk\fR).
The default value is \fBtrue\fR :
|
| ︙ | ︙ | |||
212 213 214 215 216 217 218 | \fB\-nestedLoadOk\fR This option is a convenience shortcut for \fB\-nested true\fR and thus specifies the safe interpreter will be allowed 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 | | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 |
\fB\-nestedLoadOk\fR
This option is a convenience shortcut for \fB\-nested true\fR and
thus specifies the safe interpreter will be allowed
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 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
script for that safe interpreter.
The default value (\fB{}\fR) is not to have any deletion call back.
.SH ALIASES
The following aliases are provided in a safe interpreter:
|
| ︙ | ︙ | |||
277 278 279 280 281 282 283 | code and it can request that packages be loaded. .PP Because some of these commands access the local file system, there is a 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, | | | | | 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 | code and it can request that packages be loaded. .PP Because some of these commands access the local file system, there is a 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 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 names on the local file system thus preventing safe interpreters 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 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 on Unix and \fItoken\fB\e\fIfilename\fR on Windows), where \fItoken\fR is representing one of the directories of the \fIaccessPath\fR list and \fIfilename\fR is one file in that directory (no sub directories access are allowed). |
| ︙ | ︙ | |||
316 317 318 319 320 321 322 | must end up with the extension .PQ \fB.tcl\fR or be called .PQ \fBtclIndex\fR . .PP Each element of the initial access path list will be assigned a token that will be set in | | | | | | | | | | | | | | | | | | | 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 | must end up with the extension .PQ \fB.tcl\fR or be called .PQ \fBtclIndex\fR . .PP Each element of the initial access path list will be assigned a token that will be set in 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 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 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 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 instead of relying on this default mechanism. .PP When the \fIaccessPath\fR is changed after the first creation or initialization (i.e. through \fBinterpConfigure -accessPath \fR\fIlist\fR), an \fBauto_reset\fR is automatically evaluated in the safe interpreter 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, parent interpreter, safe interpreter, child interpreter, source '\" Local Variables: '\" mode: nroff '\" End: |
Changes to doc/tcltest.n.
| ︙ | ︙ | |||
199 200 201 202 203 204 205 | to \fBoutputChannel\fR. This command also restores the original shell environment, as described by the global \fBenv\fR array. Returns an empty string. .RE .TP \fBrunAllTests\fR . | | | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 | to \fBoutputChannel\fR. This command also restores the original shell environment, as described by the global \fBenv\fR array. Returns an empty string. .RE .TP \fBrunAllTests\fR . 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 with \fBrunAllTests\fR. .SS "CONFIGURATION COMMANDS" .TP \fBconfigure\fR |
| ︙ | ︙ | |||
800 801 802 803 804 805 806 | and sorted. Then each file will be evaluated in turn. If \fBconfigure \-singleproc\fR is true, then each file will be \fBsource\fRd in the caller's context. If it is false, 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 | | | | | | | 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 | and sorted. Then each file will be evaluated in turn. If \fBconfigure \-singleproc\fR is true, then each file will be \fBsource\fRd in the caller's context. If it is false, 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 main process can continue with the rest of the test suite. In multi-process operation, 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 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 main process. .PP After evaluating all selected test files, a summary of the results is printed to \fBoutputChannel\fR. The summary includes the total number of \fBtest\fRs evaluated, broken down into those skipped, those passed, and those failed. The summary also notes the number of files evaluated, and the names of any files with failing tests or errors. A list of |
| ︙ | ︙ | |||
1130 1131 1132 1133 1134 1135 1136 | all files to be evaluated in a common interpreter. A simple way to achieve this is to have your tests define all their commands and variables in a namespace that is deleted when the test file evaluation is complete. 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, | | | | 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 |
all files to be evaluated in a common interpreter. A simple way to
achieve this is to have your tests define all their commands and variables
in a namespace that is deleted when the test file evaluation is complete.
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 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
After all \fBtest\fRs in a test file, the command \fBcleanupTests\fR
should be called.
.IP [7]
Here is a sketch of a sample test file illustrating those points:
.RS
.PP
.CS
package require tcltest 2.5
eval \fB::tcltest::configure\fR $argv
package require example
namespace eval ::example::test {
namespace import ::tcltest::*
\fBtestConstraint\fR X [expr {...}]
variable SETUP {#common setup code}
variable CLEANUP {#common cleanup code}
|
| ︙ | ︙ | |||
1171 1172 1173 1174 1175 1176 1177 | The next level of organization is a full test suite, made up of several test files. One script is used to control the entire suite. The basic function of this script is to call \fBrunAllTests\fR after 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] | | | | | 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 |
The next level of organization is a full test suite, made up of several
test files. One script is used to control the entire suite. The
basic function of this script is to call \fBrunAllTests\fR after
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 main script:
.RS
.PP
.CS
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]]]
eval \fB::tcltest::configure\fR $argv
\fB::tcltest::runAllTests\fR
.CE
.RE
|
| ︙ | ︙ |
Changes to generic/regexec.c.
| ︙ | ︙ | |||
69 70 71 72 73 74 75 |
struct arcp *incarea; /* inchain storage */
struct cnfa *cnfa;
struct colormap *cm;
chr *lastpost; /* location of last cache-flushed success */
chr *lastnopr; /* location of last cache-flushed NOPROGRESS */
struct sset *search; /* replacement-search-pointer memory */
int cptsmalloced; /* were the areas individually malloced? */
| | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 |
struct arcp *incarea; /* inchain storage */
struct cnfa *cnfa;
struct colormap *cm;
chr *lastpost; /* location of last cache-flushed success */
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 malloced area, or NULL */
};
#define WORK 1 /* number of work bitvectors needed */
/*
* Setup for non-malloc allocation for small cases.
*/
|
| ︙ | ︙ |
Changes to generic/tcl.decls.
| ︙ | ︙ | |||
326 327 328 329 330 331 332 |
size_t Tcl_ConvertElement(const char *src, char *dst, int flags)
}
declare 85 {
size_t Tcl_ConvertCountedElement(const char *src, size_t length, char *dst,
int flags)
}
declare 86 {
| | | | 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 |
size_t Tcl_ConvertElement(const char *src, char *dst, int flags)
}
declare 85 {
size_t Tcl_ConvertCountedElement(const char *src, size_t length, char *dst,
int flags)
}
declare 86 {
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 *childInterp, const char *childCmd,
Tcl_Interp *target, const char *targetCmd, int objc,
Tcl_Obj *const objv[])
}
declare 88 {
Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr,
const char *chanName, void *instanceData, int mask)
}
|
| ︙ | ︙ | |||
375 376 377 378 379 380 381 |
declare 96 {
Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp,
const char *cmdName,
Tcl_ObjCmdProc *proc, void *clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 97 {
| | | 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 |
declare 96 {
Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp,
const char *cmdName,
Tcl_ObjCmdProc *proc, void *clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 97 {
Tcl_Interp *Tcl_CreateChild(Tcl_Interp *interp, const char *name,
int isSafe)
}
declare 98 {
Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds,
Tcl_TimerProc *proc, void *clientData)
}
declare 99 {
|
| ︙ | ︙ | |||
542 543 544 545 546 547 548 |
int Tcl_Flush(Tcl_Channel chan)
}
# Removed in 9.0, TIP 559
#declare 147 {
# void Tcl_FreeResult(Tcl_Interp *interp)
#}
declare 148 {
| | | | 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 |
int Tcl_Flush(Tcl_Channel chan)
}
# Removed in 9.0, TIP 559
#declare 147 {
# void Tcl_FreeResult(Tcl_Interp *interp)
#}
declare 148 {
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 *childCmd,
Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
int *objcPtr, Tcl_Obj ***objv)
}
declare 150 {
void *Tcl_GetAssocData(Tcl_Interp *interp, const char *name,
Tcl_InterpDeleteProc **procPtr)
}
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 |
declare 161 {
int Tcl_GetErrno(void)
}
declare 162 {
const char *Tcl_GetHostName(void)
}
declare 163 {
| | | | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 |
declare 161 {
int Tcl_GetErrno(void)
}
declare 162 {
const char *Tcl_GetHostName(void)
}
declare 163 {
int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *childInterp)
}
declare 164 {
Tcl_Interp *Tcl_GetParent(Tcl_Interp *interp)
}
declare 165 {
const char *Tcl_GetNameOfExecutable(void)
}
declare 166 {
Tcl_Obj *Tcl_GetObjResult(Tcl_Interp *interp)
}
|
| ︙ | ︙ | |||
631 632 633 634 635 636 637 |
declare 170 {
size_t Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 171 {
int Tcl_GetServiceMode(void)
}
declare 172 {
| | | 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 |
declare 170 {
size_t Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 171 {
int Tcl_GetServiceMode(void)
}
declare 172 {
Tcl_Interp *Tcl_GetChild(Tcl_Interp *interp, const char *name)
}
declare 173 {
Tcl_Channel Tcl_GetStdChannel(int type)
}
# Removed in 9.0, replaced by macro.
#declare 174 {
# const char *Tcl_GetStringResult(Tcl_Interp *interp)
|
| ︙ | ︙ |
Changes to generic/tcl.h.
| ︙ | ︙ | |||
321 322 323 324 325 326 327 328 329 330 331 332 333 334 |
dev_t st_rdev;
/* Here is a 4-byte gap */
long long st_size;
struct {long long tv_sec;} st_atim;
struct {long long tv_sec;} st_mtim;
struct {long long tv_sec;} st_ctim;
} Tcl_StatBuf;
#else
typedef struct stat Tcl_StatBuf;
#endif
/*
*----------------------------------------------------------------------------
* Data structures defined opaquely in this module. The definitions below just
| > > | 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 |
dev_t st_rdev;
/* Here is a 4-byte gap */
long long st_size;
struct {long long tv_sec;} st_atim;
struct {long long tv_sec;} st_mtim;
struct {long long tv_sec;} st_ctim;
} Tcl_StatBuf;
#elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__)
typedef struct stat64 Tcl_StatBuf;
#else
typedef struct stat Tcl_StatBuf;
#endif
/*
*----------------------------------------------------------------------------
* Data structures defined opaquely in this module. The definitions below just
|
| ︙ | ︙ | |||
812 813 814 815 816 817 818 | * that condition. */ #define TCL_DONT_USE_BRACES 1 #define TCL_DONT_QUOTE_HASH 8 /* | | | > > | > | 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 | * that condition. */ #define TCL_DONT_USE_BRACES 1 #define TCL_DONT_QUOTE_HASH 8 /* * 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_INDEX_TEMP_TABLE 2 /* *---------------------------------------------------------------------------- * Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv. * WARNING: these bit choices must not conflict with the bit choices for * evalFlag bits in tclInt.h! * |
| ︙ | ︙ |
Changes to generic/tclBasic.c.
| ︙ | ︙ | |||
658 659 660 661 662 663 664 |
}
if (commandTypeInit == 0) {
TclRegisterCommandTypeName(TclObjInterpProc, "proc");
TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble");
TclRegisterCommandTypeName(TclAliasObjCmd, "alias");
TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias");
| | | 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 |
}
if (commandTypeInit == 0) {
TclRegisterCommandTypeName(TclObjInterpProc, "proc");
TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble");
TclRegisterCommandTypeName(TclAliasObjCmd, "alias");
TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias");
TclRegisterCommandTypeName(TclChildObjCmd, "interp");
TclRegisterCommandTypeName(TclInvokeImportedCmd, "import");
TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object");
TclRegisterCommandTypeName(TclOOPrivateObjectCmd, "privateObject");
TclRegisterCommandTypeName(TclOOMyClassObjCmd, "privateClass");
TclRegisterCommandTypeName(TclNRInterpCoroutine, "coroutine");
}
|
| ︙ | ︙ | |||
2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 |
if (oldRefPtr != NULL) {
cmdPtr->importRefPtr = oldRefPtr;
while (oldRefPtr != NULL) {
Command *refCmdPtr = oldRefPtr->importedCmdPtr;
dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
dataPtr->realCmdPtr = cmdPtr;
oldRefPtr = oldRefPtr->nextPtr;
}
}
/*
* We just created a command, so in its namespace and all of its parent
| > > | 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 |
if (oldRefPtr != NULL) {
cmdPtr->importRefPtr = oldRefPtr;
while (oldRefPtr != NULL) {
Command *refCmdPtr = oldRefPtr->importedCmdPtr;
dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
cmdPtr->refCount++;
TclCleanupCommandMacro(dataPtr->realCmdPtr);
dataPtr->realCmdPtr = cmdPtr;
oldRefPtr = oldRefPtr->nextPtr;
}
}
/*
* We just created a command, so in its namespace and all of its parent
|
| ︙ | ︙ | |||
3291 3292 3293 3294 3295 3296 3297 |
char *name;
/*
* Add the full name of the containing namespace, followed by the "::"
* separator, and the command name.
*/
| | | 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 |
char *name;
/*
* Add the full name of the containing namespace, followed by the "::"
* separator, and the command name.
*/
if ((cmdPtr != NULL) && TclRoutineHasName(cmdPtr)) {
if (cmdPtr->nsPtr != NULL) {
Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
Tcl_AppendToObj(objPtr, "::", 2);
}
}
if (cmdPtr->hPtr != NULL) {
|
| ︙ | ︙ | |||
3381 3382 3383 3384 3385 3386 3387 |
* invoking the deletion callback because there are cases where the
* deletion callback needs to invoke the command (e.g. object systems such
* as OTcl). However, this means that the callback could try to delete or
* rename the command. The deleted flag allows us to detect these cases
* and skip nested deletes.
*/
| | | 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 |
* invoking the deletion callback because there are cases where the
* deletion callback needs to invoke the command (e.g. object systems such
* as OTcl). However, this means that the callback could try to delete or
* rename the command. The deleted flag allows us to detect these cases
* and skip nested deletes.
*/
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
* structure. Take care to only remove the hash entry if it has not
* already been removed; otherwise if we manage to hit this function
* three times, everything goes up in smoke. [Bug 1220058]
*/
|
| ︙ | ︙ | |||
3413 3414 3415 3416 3417 3418 3419 |
* We must delete this command, even though both traces and delete procs
* may try to avoid this (renaming the command etc). Also traces and
* delete procs may try to delete the command themselves. This flag
* declares that a delete is in progress and that recursive deletes should
* be ignored.
*/
| | | 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 |
* We must delete this command, even though both traces and delete procs
* may try to avoid this (renaming the command etc). Also traces and
* delete procs may try to delete the command themselves. This flag
* declares that a delete is in progress and that recursive deletes should
* be ignored.
*/
cmdPtr->flags |= CMD_DYING;
/*
* Call trace functions for the command being deleted. Then delete its
* traces.
*/
cmdPtr->nsPtr->refCount++;
|
| ︙ | ︙ | |||
3443 3444 3445 3446 3447 3448 3449 |
}
tracePtr = nextPtr;
}
cmdPtr->tracePtr = NULL;
}
/*
| | | 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 |
}
tracePtr = nextPtr;
}
cmdPtr->tracePtr = NULL;
}
/*
* 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.
*/
TclInvalidateNsCmdLookup(cmdPtr->nsPtr);
TclNsDecrRefCount(cmdPtr->nsPtr);
|
| ︙ | ︙ | |||
3578 3579 3580 3581 3582 3583 3584 |
Tcl_InterpState state = NULL;
if (cmdPtr->flags & CMD_TRACE_ACTIVE) {
/*
* 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
| | | 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 |
Tcl_InterpState state = NULL;
if (cmdPtr->flags & CMD_TRACE_ACTIVE) {
/*
* 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_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
* "oldName" is deleted.
*/
if (cmdPtr->flags & TCL_TRACE_RENAME) {
|
| ︙ | ︙ | |||
3709 3710 3711 3712 3713 3714 3715 | * just in case the caller passed flags that might cause behaviour * unrelated to script cancellation. */ TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED); /* | | | 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 | * just in case the caller passed flags that might cause behaviour * unrelated to script cancellation. */ TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED); /* * Now, we must set the script cancellation flags on all the child * interpreters belonging to this one. */ TclSetChildCancelFlags((Tcl_Interp *) iPtr, cancelInfo->flags | CANCELED, 0); /* |
| ︙ | ︙ | |||
3877 3878 3879 3880 3881 3882 3883 | /* *---------------------------------------------------------------------- * * Tcl_Canceled -- * * Check if the script in progress has been canceled, i.e., | | | 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 | /* *---------------------------------------------------------------------- * * Tcl_Canceled -- * * Check if the script in progress has been canceled, i.e., * Tcl_CancelEval was called for this interpreter or any of its parent * interpreters. * * Results: * The return value is TCL_OK if the script evaluation has not been * canceled, TCL_ERROR otherwise. * * If "flags" contains TCL_LEAVE_ERR_MSG, an error message is returned in |
| ︙ | ︙ | |||
4746 4747 4748 4749 4750 4751 4752 |
int objc = PTR2INT(data[0]);
Tcl_Obj *commandPtr = (Tcl_Obj *)data[1];
Command *cmdPtr = (Command *)data[2];
Tcl_Obj **objv = (Tcl_Obj **)data[3];
size_t length;
const char *command = TclGetStringFromObj(commandPtr, &length);
| | | 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 |
int objc = PTR2INT(data[0]);
Tcl_Obj *commandPtr = (Tcl_Obj *)data[1];
Command *cmdPtr = (Command *)data[2];
Tcl_Obj **objv = (Tcl_Obj **)data[3];
size_t length;
const char *command = TclGetStringFromObj(commandPtr, &length);
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);
}
if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
traceCode = TclCheckInterpTraces(interp, command, length,
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
|
| ︙ | ︙ | |||
4889 4890 4891 4892 4893 4894 4895 |
const char *outerScript) /* continuation line data. This is set only in
* TclSubstTokens(), to properly handle
* [...]-nested commands. The 'outerScript'
* refers to the most-outer script containing
* the embedded command, which is refered to
* by 'script'. The 'clNextOuter' refers to
* the current entry in the table of
| | | 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 |
const char *outerScript) /* continuation line data. This is set only in
* TclSubstTokens(), to properly handle
* [...]-nested commands. The 'outerScript'
* refers to the most-outer script containing
* the embedded command, which is refered to
* by 'script'. The 'clNextOuter' refers to
* the current entry in the table of
* continuation lines in this "main script",
* and the character offsets are relative to
* the 'outerScript' as well.
*
* If outerScript == script, then this call is
* for the outer-most script/command. See
* Tcl_EvalEx() and TclEvalObjEx() for places
* generating arguments for which this is
|
| ︙ | ︙ | |||
5866 5867 5868 5869 5870 5871 5872 | * This also preserves any associations between list elements and * location information for such elements. */ /* * Shimmer protection! Always pass an unshared obj. The caller could * incr the refCount of objPtr AFTER calling us! To be completely safe | | | 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 | * This also preserves any associations between list elements and * location information for such elements. */ /* * 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 of the refCounts for * both listPtr and objPtr. * * TODO: Create a test to demo this need, or eliminate it. * FIXME OPT: preserve just the internal rep? */ Tcl_IncrRefCount(objPtr); |
| ︙ | ︙ | |||
6421 6422 6423 6424 6425 6426 6427 |
Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
}
return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv);
}
int
TclNRInvoke(
| | | 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 |
Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
}
return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv);
}
int
TclNRInvoke(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
Tcl_HashTable *hTblPtr; /* Table of hidden commands. */
const char *cmdName; /* Name of the command from objv[0]. */
|
| ︙ | ︙ | |||
6751 6752 6753 6754 6755 6756 6757 | * None. * *---------------------------------------------------------------------- */ static int ExprCeilFunc( | | | 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 |
* None.
*
*----------------------------------------------------------------------
*/
static int
ExprCeilFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter list. */
{
int code;
double d;
|
| ︙ | ︙ | |||
6791 6792 6793 6794 6795 6796 6797 |
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d)));
}
return TCL_OK;
}
static int
ExprFloorFunc(
| | | 6793 6794 6795 6796 6797 6798 6799 6800 6801 6802 6803 6804 6805 6806 6807 |
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d)));
}
return TCL_OK;
}
static int
ExprFloorFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter list. */
{
int code;
double d;
|
| ︙ | ︙ | |||
6831 6832 6833 6834 6835 6836 6837 |
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d)));
}
return TCL_OK;
}
static int
ExprIsqrtFunc(
| | | 6833 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 |
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d)));
}
return TCL_OK;
}
static int
ExprIsqrtFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter list. */
{
ClientData ptr;
int type;
double d;
|
| ︙ | ︙ | |||
6937 6938 6939 6940 6941 6942 6943 |
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range", NULL);
return TCL_ERROR;
}
static int
ExprSqrtFunc(
| | | 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 6952 6953 |
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range", NULL);
return TCL_ERROR;
}
static int
ExprSqrtFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter list. */
{
int code;
double d;
|
| ︙ | ︙ | |||
7105 7106 7107 7108 7109 7110 7111 |
}
errno = 0;
return CheckDoubleResult(interp, func(d1, d2));
}
static int
ExprAbsFunc(
| | | 7107 7108 7109 7110 7111 7112 7113 7114 7115 7116 7117 7118 7119 7120 7121 |
}
errno = 0;
return CheckDoubleResult(interp, func(d1, d2));
}
static int
ExprAbsFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Parameter vector. */
{
ClientData ptr;
int type;
|
| ︙ | ︙ | |||
7204 7205 7206 7207 7208 7209 7210 |
#endif
}
return TCL_OK;
}
static int
ExprBoolFunc(
| | | | 7206 7207 7208 7209 7210 7211 7212 7213 7214 7215 7216 7217 7218 7219 7220 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 7231 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 |
#endif
}
return TCL_OK;
}
static int
ExprBoolFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
int value;
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[1], &value) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
return TCL_OK;
}
static int
ExprDoubleFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
double dResult;
|
| ︙ | ︙ | |||
7252 7253 7254 7255 7256 7257 7258 |
}
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
return TCL_OK;
}
static int
ExprIntFunc(
| | | 7254 7255 7256 7257 7258 7259 7260 7261 7262 7263 7264 7265 7266 7267 7268 |
}
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
return TCL_OK;
}
static int
ExprIntFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
double d;
int type;
|
| ︙ | ︙ | |||
7308 7309 7310 7311 7312 7313 7314 |
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
}
static int
ExprWideFunc(
| | | | 7310 7311 7312 7313 7314 7315 7316 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 |
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
}
static int
ExprWideFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
Tcl_WideInt wResult;
if (ExprIntFunc(NULL, interp, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
TclGetWideBitsFromObj(NULL, Tcl_GetObjResult(interp), &wResult);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult));
return TCL_OK;
}
/*
* Common implmentation of max() and min().
*/
static int
ExprMaxMinFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv, /* Actual parameter vector. */
int op) /* Comparison direction */
{
Tcl_Obj *res;
|
| ︙ | ︙ | |||
7369 7370 7371 7372 7373 7374 7375 |
Tcl_SetObjResult(interp, res);
return TCL_OK;
}
static int
ExprMaxFunc(
| | | | | 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 7396 7397 7398 7399 7400 7401 7402 7403 7404 7405 7406 7407 |
Tcl_SetObjResult(interp, res);
return TCL_OK;
}
static int
ExprMaxFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
return ExprMaxMinFunc(NULL, interp, objc, objv, MP_GT);
}
static int
ExprMinFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
return ExprMaxMinFunc(NULL, interp, objc, objv, MP_LT);
}
static int
ExprRandFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
Interp *iPtr = (Interp *) interp;
double dResult;
|
| ︙ | ︙ | |||
7484 7485 7486 7487 7488 7489 7490 |
TclNewDoubleObj(oResult, dResult);
Tcl_SetObjResult(interp, oResult);
return TCL_OK;
}
static int
ExprRoundFunc(
| | | 7486 7487 7488 7489 7490 7491 7492 7493 7494 7495 7496 7497 7498 7499 7500 |
TclNewDoubleObj(oResult, dResult);
Tcl_SetObjResult(interp, oResult);
return TCL_OK;
}
static int
ExprRoundFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Parameter vector. */
{
double d;
ClientData ptr;
|
| ︙ | ︙ | |||
7563 7564 7565 7566 7567 7568 7569 |
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
}
static int
ExprSrandFunc(
| | | 7565 7566 7567 7568 7569 7570 7571 7572 7573 7574 7575 7576 7577 7578 7579 |
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
}
static int
ExprSrandFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Parameter vector. */
{
Interp *iPtr = (Interp *) interp;
Tcl_WideInt w = 0; /* Initialized to avoid compiler warning. */
|
| ︙ | ︙ | |||
7752 7753 7754 7755 7756 7757 7758 | #error "unknown or unexpected TCL_FPCLASSIFY_MODE" #endif /* TCL_FPCLASSIFY_MODE */ #endif /* !fpclassify */ } static int ExprIsFiniteFunc( | | | 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 7768 |
#error "unknown or unexpected TCL_FPCLASSIFY_MODE"
#endif /* TCL_FPCLASSIFY_MODE */
#endif /* !fpclassify */
}
static int
ExprIsFiniteFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Actual parameter list */
{
double d;
ClientData ptr;
|
| ︙ | ︙ | |||
7783 7784 7785 7786 7787 7788 7789 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsInfinityFunc(
| | | 7785 7786 7787 7788 7789 7790 7791 7792 7793 7794 7795 7796 7797 7798 7799 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsInfinityFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Actual parameter list */
{
double d;
ClientData ptr;
|
| ︙ | ︙ | |||
7813 7814 7815 7816 7817 7818 7819 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsNaNFunc(
| | | 7815 7816 7817 7818 7819 7820 7821 7822 7823 7824 7825 7826 7827 7828 7829 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsNaNFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Actual parameter list */
{
double d;
ClientData ptr;
|
| ︙ | ︙ | |||
7843 7844 7845 7846 7847 7848 7849 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsNormalFunc(
| | | 7845 7846 7847 7848 7849 7850 7851 7852 7853 7854 7855 7856 7857 7858 7859 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsNormalFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Actual parameter list */
{
double d;
ClientData ptr;
|
| ︙ | ︙ | |||
7873 7874 7875 7876 7877 7878 7879 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsSubnormalFunc(
| | | 7875 7876 7877 7878 7879 7880 7881 7882 7883 7884 7885 7886 7887 7888 7889 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsSubnormalFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Actual parameter list */
{
double d;
ClientData ptr;
|
| ︙ | ︙ | |||
7903 7904 7905 7906 7907 7908 7909 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsUnorderedFunc(
| | | 7905 7906 7907 7908 7909 7910 7911 7912 7913 7914 7915 7916 7917 7918 7919 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsUnorderedFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Actual parameter list */
{
double d;
ClientData ptr;
|
| ︙ | ︙ | |||
7944 7945 7946 7947 7948 7949 7950 |
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
FloatClassifyObjCmd(
| | | 7946 7947 7948 7949 7950 7951 7952 7953 7954 7955 7956 7957 7958 7959 7960 |
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
FloatClassifyObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Actual parameter list */
{
double d;
Tcl_Obj *objPtr;
|
| ︙ | ︙ | |||
8053 8054 8055 8056 8057 8058 8059 | * The 'tcl-probe' DTrace probe is triggered (if it is enabled). * *---------------------------------------------------------------------- */ static int DTraceObjCmd( | | | 8055 8056 8057 8058 8059 8060 8061 8062 8063 8064 8065 8066 8067 8068 8069 |
* The 'tcl-probe' DTrace probe is triggered (if it is enabled).
*
*----------------------------------------------------------------------
*/
static int
DTraceObjCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (TCL_DTRACE_TCL_PROBE_ENABLED()) {
char *a[10];
int i = 0;
|
| ︙ | ︙ | |||
8437 8438 8439 8440 8441 8442 8443 | * updated so that its data[1] field contains the tailcall list. * *---------------------------------------------------------------------- */ int TclNRTailcallObjCmd( | | | 8439 8440 8441 8442 8443 8444 8445 8446 8447 8448 8449 8450 8451 8452 8453 |
* updated so that its data[1] field contains the tailcall list.
*
*----------------------------------------------------------------------
*/
int
TclNRTailcallObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
if (objc < 1) {
|
| ︙ | ︙ | |||
8630 8631 8632 8633 8634 8635 8636 |
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
clientData, NULL, NULL);
return TCL_OK;
}
int
TclNRYieldToObjCmd(
| | | 8632 8633 8634 8635 8636 8637 8638 8639 8640 8641 8642 8643 8644 8645 8646 |
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
clientData, NULL, NULL);
return TCL_OK;
}
int
TclNRYieldToObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
Tcl_Obj *listPtr, *nsObjPtr;
Tcl_Namespace *nsPtr = TclGetCurrentNamespace(interp);
|
| ︙ | ︙ | |||
8753 8754 8755 8756 8757 8758 8759 |
return result;
}
NRE_ASSERT(COR_IS_SUSPENDED(corPtr));
SAVE_CONTEXT(corPtr->running);
RESTORE_CONTEXT(corPtr->caller);
| | | 8755 8756 8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 |
return result;
}
NRE_ASSERT(COR_IS_SUSPENDED(corPtr));
SAVE_CONTEXT(corPtr->running);
RESTORE_CONTEXT(corPtr->caller);
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
* restore both the caller's context and interp state.
*/
return RewindCoroutine(corPtr, result);
|
| ︙ | ︙ | |||
8940 8941 8942 8943 8944 8945 8946 | * Implementation of [::tcl::unsupported::corotype] command. * *---------------------------------------------------------------------- */ static int CoroTypeObjCmd( | | | 8942 8943 8944 8945 8946 8947 8948 8949 8950 8951 8952 8953 8954 8955 8956 |
* Implementation of [::tcl::unsupported::corotype] command.
*
*----------------------------------------------------------------------
*/
static int
CoroTypeObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Command *cmdPtr;
CoroutineData *corPtr;
|
| ︙ | ︙ | |||
9030 9031 9032 9033 9034 9035 9036 |
return NULL;
}
return (CoroutineData *)cmdPtr->objClientData;
}
static int
TclNRCoroInjectObjCmd(
| | | 9032 9033 9034 9035 9036 9037 9038 9039 9040 9041 9042 9043 9044 9045 9046 |
return NULL;
}
return (CoroutineData *)cmdPtr->objClientData;
}
static int
TclNRCoroInjectObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CoroutineData *corPtr;
ExecEnv *savedEEPtr = iPtr->execEnvPtr;
|
| ︙ | ︙ | |||
9075 9076 9077 9078 9079 9080 9081 |
iPtr->execEnvPtr = savedEEPtr;
return TCL_OK;
}
static int
TclNRCoroProbeObjCmd(
| | | 9077 9078 9079 9080 9081 9082 9083 9084 9085 9086 9087 9088 9089 9090 9091 |
iPtr->execEnvPtr = savedEEPtr;
return TCL_OK;
}
static int
TclNRCoroProbeObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CoroutineData *corPtr;
ExecEnv *savedEEPtr = iPtr->execEnvPtr;
int numLevels, unused;
|
| ︙ | ︙ | |||
9268 9269 9270 9271 9272 9273 9274 | * Implementation of [::tcl::unsupported::inject] command. * *---------------------------------------------------------------------- */ static int NRInjectObjCmd( | | | 9270 9271 9272 9273 9274 9275 9276 9277 9278 9279 9280 9281 9282 9283 9284 |
* Implementation of [::tcl::unsupported::inject] command.
*
*----------------------------------------------------------------------
*/
static int
NRInjectObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CoroutineData *corPtr;
ExecEnv *savedEEPtr = iPtr->execEnvPtr;
|
| ︙ | ︙ | |||
9377 9378 9379 9380 9381 9382 9383 | * description of what this does. * *---------------------------------------------------------------------- */ int TclNRCoroutineObjCmd( | | | 9379 9380 9381 9382 9383 9384 9385 9386 9387 9388 9389 9390 9391 9392 9393 |
* description of what this does.
*
*----------------------------------------------------------------------
*/
int
TclNRCoroutineObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Command *cmdPtr;
CoroutineData *corPtr;
const char *procName, *simpleName;
|
| ︙ | ︙ | |||
9510 9511 9512 9513 9514 9515 9516 | /* * This is used in the [info] ensemble */ int TclInfoCoroutineCmd( | | | | 9512 9513 9514 9515 9516 9517 9518 9519 9520 9521 9522 9523 9524 9525 9526 9527 9528 9529 9530 9531 9532 9533 9534 9535 9536 9537 9538 |
/*
* This is used in the [info] ensemble
*/
int
TclInfoCoroutineCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) {
Tcl_Obj *namePtr;
TclNewObj(namePtr);
Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, namePtr);
Tcl_SetObjResult(interp, namePtr);
}
return TCL_OK;
|
| ︙ | ︙ |
Changes to generic/tclBinary.c.
| ︙ | ︙ | |||
270 271 272 273 274 275 276 |
size_t bad; /* Index of the character that is a nonbyte.
* If all characters are bytes, bad = used,
* though then we should never read it. */
size_t used; /* The number of bytes used in the byte
* array. */
size_t allocated; /* The amount of space actually allocated
* minus 1 byte. */
| | | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 |
size_t bad; /* Index of the character that is a nonbyte.
* If all characters are bytes, bad = used,
* though then we should never read it. */
size_t used; /* The number of bytes used in the byte
* array. */
size_t allocated; /* The amount of space actually allocated
* minus 1 byte. */
unsigned char bytes[TCLFLEXARRAY]; /* The array of bytes. The actual size of this
* field depends on the 'allocated' field
* above. */
} ByteArray;
#define BYTEARRAY_SIZE(len) \
(offsetof(ByteArray, bytes) + (len))
#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1)
|
| ︙ | ︙ |
Changes to generic/tclClock.c.
| ︙ | ︙ | |||
259 260 261 262 263 264 265 |
{"milliseconds", ClockMillisecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(2), 0},
{"scan", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL , 0},
{"seconds", ClockSecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(3), 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
| | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 |
{"milliseconds", ClockMillisecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(2), 0},
{"scan", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL , 0},
{"seconds", ClockSecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(3), 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
* Safe interps get [::clock] as alias to a parent, so do not need their
* own copies of the support routines.
*/
if (Tcl_IsSafe(interp)) {
return;
}
|
| ︙ | ︙ |
Changes to generic/tclCmdIL.c.
| ︙ | ︙ | |||
1022 1023 1024 1025 1026 1027 1028 |
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
return TCL_ERROR;
}
target = interp;
if (objc == 2) {
| | | 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 |
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
return TCL_ERROR;
}
target = interp;
if (objc == 2) {
target = Tcl_GetChild(interp, TclGetString(objv[1]));
if (target == NULL) {
return TCL_ERROR;
}
}
iPtr = (Interp *) target;
Tcl_SetObjResult(interp, iPtr->errorStack);
|
| ︙ | ︙ | |||
2138 2139 2140 2141 2142 2143 2144 |
command = Tcl_FindCommand(interp, TclGetString(objv[1]), NULL,
TCL_LEAVE_ERR_MSG);
if (command == NULL) {
return TCL_ERROR;
}
/*
| | | 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 |
command = Tcl_FindCommand(interp, TclGetString(objv[1]), NULL,
TCL_LEAVE_ERR_MSG);
if (command == NULL) {
return TCL_ERROR;
}
/*
* There's one special case: safe child interpreters can't see aliases as
* aliases as they're part of the security mechanisms.
*/
if (Tcl_IsSafe(interp)
&& (((Command *) command)->objProc == TclAliasObjCmd)) {
Tcl_AppendResult(interp, "native", NULL);
} else {
|
| ︙ | ︙ | |||
3831 3832 3833 3834 3835 3836 3837 |
itemPtr = TclNewWideIntObjFromSize(index+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
Tcl_ListObjAppendElement(interp, itemPtr, TclNewWideIntObjFromSize(
TclIndexDecode(sortInfo.indexv[j], listc)));
}
Tcl_SetObjResult(interp, itemPtr);
} else {
| | | 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 |
itemPtr = TclNewWideIntObjFromSize(index+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
Tcl_ListObjAppendElement(interp, itemPtr, TclNewWideIntObjFromSize(
TclIndexDecode(sortInfo.indexv[j], listc)));
}
Tcl_SetObjResult(interp, itemPtr);
} else {
Tcl_SetObjResult(interp, TclNewWideIntObjFromSize((size_t)index));
}
} else if (index < 0) {
/*
* Is this superfluous? The result should be a blank object by
* default...
*/
|
| ︙ | ︙ |
Changes to generic/tclCompCmds.c.
| ︙ | ︙ | |||
386 387 388 389 390 391 392 |
/*
* Prepare for the internal foreach.
*/
keyVar = AnonymousLocal(envPtr);
valVar = AnonymousLocal(envPtr);
| | | | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 |
/*
* Prepare for the internal foreach.
*/
keyVar = AnonymousLocal(envPtr);
valVar = AnonymousLocal(envPtr);
infoPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *));
infoPtr->numLists = 1;
infoPtr->varLists[0] = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) + 2 * sizeof(int));
infoPtr->varLists[0]->numVars = 2;
infoPtr->varLists[0]->varIndexes[0] = keyVar;
infoPtr->varLists[0]->varIndexes[1] = valVar;
infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr);
/*
* Start issuing instructions to write to the array.
|
| ︙ | ︙ | |||
1788 1789 1790 1791 1792 1793 1794 |
/*
* Assemble the instruction metadata. This is complex enough that it is
* represented as auxData; it holds an ordered list of variable indices
* that are to be used.
*/
| | | 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 |
/*
* Assemble the instruction metadata. This is complex enough that it is
* represented as auxData; it holds an ordered list of variable indices
* that are to be used.
*/
duiPtr = (DictUpdateInfo *)Tcl_Alloc(offsetof(DictUpdateInfo, varIndices) + sizeof(int) * numVars);
duiPtr->length = numVars;
keyTokenPtrs = (Tcl_Token **)TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars);
tokenPtr = TokenAfter(dictVarTokenPtr);
for (i=0 ; i<numVars ; i++) {
/*
* Put keys to one side for later compilation to bytecode.
|
| ︙ | ︙ | |||
2270 2271 2272 2273 2274 2275 2276 |
DupDictUpdateInfo(
ClientData clientData)
{
DictUpdateInfo *dui1Ptr, *dui2Ptr;
size_t len;
dui1Ptr = (DictUpdateInfo *)clientData;
| | | 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 |
DupDictUpdateInfo(
ClientData clientData)
{
DictUpdateInfo *dui1Ptr, *dui2Ptr;
size_t len;
dui1Ptr = (DictUpdateInfo *)clientData;
len = offsetof(DictUpdateInfo, varIndices) + sizeof(int) * dui1Ptr->length;
dui2Ptr = (DictUpdateInfo *)Tcl_Alloc(len);
memcpy(dui2Ptr, dui1Ptr, len);
return dui2Ptr;
}
static void
FreeDictUpdateInfo(
|
| ︙ | ︙ | |||
2720 2721 2722 2723 2724 2725 2726 |
/*
* Create and initialize the ForeachInfo and ForeachVarList data
* structures describing this command. Then create a AuxData record
* pointing to the ForeachInfo structure.
*/
numLists = (numWords - 2)/2;
| | | | 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 |
/*
* Create and initialize the ForeachInfo and ForeachVarList data
* structures describing this command. Then create a AuxData record
* pointing to the ForeachInfo structure.
*/
numLists = (numWords - 2)/2;
infoPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists)
+ numLists * sizeof(ForeachVarList *));
infoPtr->numLists = 0; /* Count this up as we go */
/*
* Parse each var list into sequence of var names. Don't
* compile the foreach inline if any var name needs substitutions or isn't
* a scalar, or if any var list needs substitutions.
*/
|
| ︙ | ︙ | |||
2754 2755 2756 2757 2758 2759 2760 |
if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) ||
TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) ||
numVars == 0) {
code = TCL_ERROR;
goto done;
}
| | | | 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 |
if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) ||
TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) ||
numVars == 0) {
code = TCL_ERROR;
goto done;
}
varListPtr = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes)
+ numVars * sizeof(int));
varListPtr->numVars = numVars;
infoPtr->varLists[i/2] = varListPtr;
infoPtr->numLists++;
for (j = 0; j < numVars; j++) {
Tcl_Obj *varNameObj;
const char *bytes;
|
| ︙ | ︙ | |||
2892 2893 2894 2895 2896 2897 2898 |
* data to duplicate. */
{
ForeachInfo *srcPtr = (ForeachInfo *)clientData;
ForeachInfo *dupPtr;
ForeachVarList *srcListPtr, *dupListPtr;
int numVars, i, j, numLists = srcPtr->numLists;
| | | | 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 |
* data to duplicate. */
{
ForeachInfo *srcPtr = (ForeachInfo *)clientData;
ForeachInfo *dupPtr;
ForeachVarList *srcListPtr, *dupListPtr;
int numVars, i, j, numLists = srcPtr->numLists;
dupPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists)
+ numLists * sizeof(ForeachVarList *));
dupPtr->numLists = numLists;
dupPtr->firstValueTemp = srcPtr->firstValueTemp;
dupPtr->loopCtTemp = srcPtr->loopCtTemp;
for (i = 0; i < numLists; i++) {
srcListPtr = srcPtr->varLists[i];
numVars = srcListPtr->numVars;
dupListPtr = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes)
+ numVars * sizeof(int));
dupListPtr->numVars = numVars;
for (j = 0; j < numVars; j++) {
dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
}
dupPtr->varLists[i] = dupListPtr;
}
|
| ︙ | ︙ |
Changes to generic/tclCompile.c.
| ︙ | ︙ | |||
825 826 827 828 829 830 831 |
* Check for optimizations!
*
* Test if the generated code is free of most hazards; if so, recompile
* but with generation of INST_START_CMD disabled. This produces somewhat
* faster code in some cases, and more compact code in more.
*/
| | | 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 |
* Check for optimizations!
*
* Test if the generated code is free of most hazards; if so, recompile
* but with generation of INST_START_CMD disabled. This produces somewhat
* faster code in some cases, and more compact code in more.
*/
if (Tcl_GetParent(interp) == NULL &&
!Tcl_LimitTypeEnabled(interp, TCL_LIMIT_COMMANDS|TCL_LIMIT_TIME)
&& IsCompactibleCompileEnv(&compEnv)) {
TclFreeCompileEnv(&compEnv);
iPtr->compiledProcPtr = procPtr;
TclInitCompileEnv(interp, &compEnv, stringPtr, length,
iPtr->invokeCmdFramePtr, iPtr->invokeWord);
if (clLocPtr) {
|
| ︙ | ︙ | |||
1811 1812 1813 1814 1815 1816 1817 |
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
bytes = TclGetStringFromObj(cmdObj, &length);
cmdLitIdx = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags);
| | | 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 |
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
bytes = TclGetStringFromObj(cmdObj, &length);
cmdLitIdx = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags);
if (cmdPtr && TclRoutineHasName(cmdPtr)) {
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
}
TclEmitPush(cmdLitIdx, envPtr);
}
void
TclCompileInvocation(
|
| ︙ | ︙ |
Changes to generic/tclCompile.h.
| ︙ | ︙ | |||
965 966 967 968 969 970 971 |
* only foreach commands inside procedure bodies are compiled inline so a
* ForeachVarList structure always describes local variables. Furthermore,
* only scalar variables are supported for inline-compiled foreach loops.
*/
typedef struct ForeachVarList {
int numVars; /* The number of variables in the list. */
| | | 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 |
* only foreach commands inside procedure bodies are compiled inline so a
* ForeachVarList structure always describes local variables. Furthermore,
* only scalar variables are supported for inline-compiled foreach loops.
*/
typedef struct ForeachVarList {
int numVars; /* The number of variables in the list. */
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
* field will be large enough to numVars
* indexes. THIS MUST BE THE LAST FIELD IN THE
* STRUCTURE! */
} ForeachVarList;
|
| ︙ | ︙ | |||
989 990 991 992 993 994 995 |
* lists of the foreach command. */
int firstValueTemp; /* Index of the first temp var in a proc frame
* used to point to a value list. */
int loopCtTemp; /* Index of temp var in a proc frame holding
* the loop's iteration count. Used to
* determine next value list element to assign
* each loop var. */
| | | 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 |
* lists of the foreach command. */
int firstValueTemp; /* Index of the first temp var in a proc frame
* used to point to a value list. */
int loopCtTemp; /* Index of temp var in a proc frame holding
* the loop's iteration count. Used to
* determine next value list element to assign
* each loop var. */
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
* LAST FIELD IN THE STRUCTURE! */
} ForeachInfo;
/*
|
| ︙ | ︙ | |||
1020 1021 1022 1023 1024 1025 1026 |
* Structure used to hold information about a [dict update] command that is
* needed during program execution. These structures are stored in CompileEnv
* and ByteCode structures as auxiliary data.
*/
typedef struct {
size_t length; /* Size of array */
| | | 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 |
* Structure used to hold information about a [dict update] command that is
* needed during program execution. These structures are stored in CompileEnv
* and ByteCode structures as auxiliary data.
*/
typedef struct {
size_t length; /* Size of array */
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
* take account of this. MUST BE LAST FIELD IN
* STRUCTURE. */
} DictUpdateInfo;
|
| ︙ | ︙ |
Changes to generic/tclDecls.h.
| ︙ | ︙ | |||
263 264 265 266 267 268 269 | /* 84 */ EXTERN size_t Tcl_ConvertElement(const char *src, char *dst, int flags); /* 85 */ EXTERN size_t Tcl_ConvertCountedElement(const char *src, size_t length, char *dst, int flags); /* 86 */ | | | | | | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 | /* 84 */ EXTERN size_t Tcl_ConvertElement(const char *src, char *dst, int flags); /* 85 */ EXTERN size_t Tcl_ConvertCountedElement(const char *src, size_t length, char *dst, int flags); /* 86 */ 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 *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 88 */ EXTERN Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr, const char *chanName, void *instanceData, int mask); /* 89 */ |
| ︙ | ︙ | |||
303 304 305 306 307 308 309 | /* Slot 95 is reserved */ /* 96 */ EXTERN Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 97 */ | | | | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 | /* Slot 95 is reserved */ /* 96 */ EXTERN Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 97 */ EXTERN Tcl_Interp * Tcl_CreateChild(Tcl_Interp *interp, const char *name, int isSafe); /* 98 */ EXTERN Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, Tcl_TimerProc *proc, void *clientData); /* 99 */ EXTERN Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, void *clientData); /* 100 */ |
| ︙ | ︙ | |||
432 433 434 435 436 437 438 | EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 146 */ EXTERN int Tcl_Flush(Tcl_Channel chan); /* Slot 147 is reserved */ /* 148 */ EXTERN int Tcl_GetAlias(Tcl_Interp *interp, | | | | 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 | EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 146 */ EXTERN int Tcl_Flush(Tcl_Channel chan); /* Slot 147 is reserved */ /* 148 */ EXTERN int Tcl_GetAlias(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 149 */ EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 150 */ EXTERN void * Tcl_GetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); |
| ︙ | ︙ | |||
478 479 480 481 482 483 484 | Tcl_Command command); /* 161 */ EXTERN int Tcl_GetErrno(void); /* 162 */ EXTERN const char * Tcl_GetHostName(void); /* 163 */ EXTERN int Tcl_GetInterpPath(Tcl_Interp *interp, | | | | 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 | Tcl_Command command); /* 161 */ EXTERN int Tcl_GetErrno(void); /* 162 */ EXTERN const char * Tcl_GetHostName(void); /* 163 */ EXTERN int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *childInterp); /* 164 */ EXTERN Tcl_Interp * Tcl_GetParent(Tcl_Interp *interp); /* 165 */ EXTERN const char * Tcl_GetNameOfExecutable(void); /* 166 */ EXTERN Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp); #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 167 */ EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, |
| ︙ | ︙ | |||
506 507 508 509 510 511 512 | /* 169 */ EXTERN size_t Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr); /* 170 */ EXTERN size_t Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 171 */ EXTERN int Tcl_GetServiceMode(void); /* 172 */ | | < | 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 | /* 169 */ EXTERN size_t Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr); /* 170 */ EXTERN size_t Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 171 */ EXTERN int Tcl_GetServiceMode(void); /* 172 */ EXTERN Tcl_Interp * Tcl_GetChild(Tcl_Interp *interp, const char *name); /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel(int type); /* Slot 174 is reserved */ /* Slot 175 is reserved */ /* 176 */ EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags); |
| ︙ | ︙ | |||
1861 1862 1863 1864 1865 1866 1867 |
void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 79 */
void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, void *clientData); /* 80 */
void (*reserved81)(void);
int (*tcl_CommandComplete) (const char *cmd); /* 82 */
char * (*tcl_Concat) (int argc, const char *const *argv); /* 83 */
size_t (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */
size_t (*tcl_ConvertCountedElement) (const char *src, size_t length, char *dst, int flags); /* 85 */
| | | | | 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 |
void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 79 */
void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, void *clientData); /* 80 */
void (*reserved81)(void);
int (*tcl_CommandComplete) (const char *cmd); /* 82 */
char * (*tcl_Concat) (int argc, const char *const *argv); /* 83 */
size_t (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */
size_t (*tcl_ConvertCountedElement) (const char *src, size_t length, char *dst, int flags); /* 85 */
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, void *instanceData, int mask); /* 88 */
void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, void *clientData); /* 89 */
void (*tcl_CreateCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 90 */
Tcl_Command (*tcl_CreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 91 */
void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, void *clientData); /* 92 */
void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 93 */
Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */
void (*reserved95)(void);
Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */
Tcl_Interp * (*tcl_CreateChild) (Tcl_Interp *interp, const char *name, int isSafe); /* 97 */
Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, void *clientData); /* 98 */
Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, void *clientData); /* 99 */
void (*tcl_DeleteAssocData) (Tcl_Interp *interp, const char *name); /* 100 */
void (*tcl_DeleteChannelHandler) (Tcl_Channel chan, Tcl_ChannelProc *proc, void *clientData); /* 101 */
void (*tcl_DeleteCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 102 */
int (*tcl_DeleteCommand) (Tcl_Interp *interp, const char *cmdName); /* 103 */
int (*tcl_DeleteCommandFromToken) (Tcl_Interp *interp, Tcl_Command command); /* 104 */
|
| ︙ | ︙ | |||
1923 1924 1925 1926 1927 1928 1929 |
int (*tcl_ExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 141 */
int (*tcl_ExprString) (Tcl_Interp *interp, const char *expr); /* 142 */
void (*tcl_Finalize) (void); /* 143 */
void (*reserved144)(void);
Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */
int (*tcl_Flush) (Tcl_Channel chan); /* 146 */
void (*reserved147)(void);
| | | | | | | 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 |
int (*tcl_ExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 141 */
int (*tcl_ExprString) (Tcl_Interp *interp, const char *expr); /* 142 */
void (*tcl_Finalize) (void); /* 143 */
void (*reserved144)(void);
Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */
int (*tcl_Flush) (Tcl_Channel chan); /* 146 */
void (*reserved147)(void);
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 */
void * (*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 */
int (*tcl_GetChannelHandle) (Tcl_Channel chan, int direction, void **handlePtr); /* 153 */
void * (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */
int (*tcl_GetChannelMode) (Tcl_Channel chan); /* 155 */
const char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */
int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 157 */
const Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */
int (*tcl_GetCommandInfo) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 159 */
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 *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 */
int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); /* 167 */
#endif /* UNIX */
#if defined(_WIN32) /* WIN */
void (*reserved167)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); /* 167 */
#endif /* MACOSX */
Tcl_PathType (*tcl_GetPathType) (const char *path); /* 168 */
size_t (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */
size_t (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */
int (*tcl_GetServiceMode) (void); /* 171 */
Tcl_Interp * (*tcl_GetChild) (Tcl_Interp *interp, const char *name); /* 172 */
Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */
void (*reserved174)(void);
void (*reserved175)(void);
const char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */
void (*reserved177)(void);
void (*reserved178)(void);
int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */
|
| ︙ | ︙ | |||
2637 2638 2639 2640 2641 2642 2643 | #define Tcl_CreateExitHandler \ (tclStubsPtr->tcl_CreateExitHandler) /* 93 */ #define Tcl_CreateInterp \ (tclStubsPtr->tcl_CreateInterp) /* 94 */ /* Slot 95 is reserved */ #define Tcl_CreateObjCommand \ (tclStubsPtr->tcl_CreateObjCommand) /* 96 */ | | | | 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 | #define Tcl_CreateExitHandler \ (tclStubsPtr->tcl_CreateExitHandler) /* 93 */ #define Tcl_CreateInterp \ (tclStubsPtr->tcl_CreateInterp) /* 94 */ /* Slot 95 is reserved */ #define Tcl_CreateObjCommand \ (tclStubsPtr->tcl_CreateObjCommand) /* 96 */ #define Tcl_CreateChild \ (tclStubsPtr->tcl_CreateChild) /* 97 */ #define Tcl_CreateTimerHandler \ (tclStubsPtr->tcl_CreateTimerHandler) /* 98 */ #define Tcl_CreateTrace \ (tclStubsPtr->tcl_CreateTrace) /* 99 */ #define Tcl_DeleteAssocData \ (tclStubsPtr->tcl_DeleteAssocData) /* 100 */ #define Tcl_DeleteChannelHandler \ |
| ︙ | ︙ | |||
2767 2768 2769 2770 2771 2772 2773 | (tclStubsPtr->tcl_GetCommandName) /* 160 */ #define Tcl_GetErrno \ (tclStubsPtr->tcl_GetErrno) /* 161 */ #define Tcl_GetHostName \ (tclStubsPtr->tcl_GetHostName) /* 162 */ #define Tcl_GetInterpPath \ (tclStubsPtr->tcl_GetInterpPath) /* 163 */ | | | | | | 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 | (tclStubsPtr->tcl_GetCommandName) /* 160 */ #define Tcl_GetErrno \ (tclStubsPtr->tcl_GetErrno) /* 161 */ #define Tcl_GetHostName \ (tclStubsPtr->tcl_GetHostName) /* 162 */ #define Tcl_GetInterpPath \ (tclStubsPtr->tcl_GetInterpPath) /* 163 */ #define Tcl_GetParent \ (tclStubsPtr->tcl_GetParent) /* 164 */ #define Tcl_GetNameOfExecutable \ (tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */ #define Tcl_GetObjResult \ (tclStubsPtr->tcl_GetObjResult) /* 166 */ #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ #define Tcl_GetOpenFile \ (tclStubsPtr->tcl_GetOpenFile) /* 167 */ #endif /* UNIX */ #ifdef MAC_OSX_TCL /* MACOSX */ #define Tcl_GetOpenFile \ (tclStubsPtr->tcl_GetOpenFile) /* 167 */ #endif /* MACOSX */ #define Tcl_GetPathType \ (tclStubsPtr->tcl_GetPathType) /* 168 */ #define Tcl_Gets \ (tclStubsPtr->tcl_Gets) /* 169 */ #define Tcl_GetsObj \ (tclStubsPtr->tcl_GetsObj) /* 170 */ #define Tcl_GetServiceMode \ (tclStubsPtr->tcl_GetServiceMode) /* 171 */ #define Tcl_GetChild \ (tclStubsPtr->tcl_GetChild) /* 172 */ #define Tcl_GetStdChannel \ (tclStubsPtr->tcl_GetStdChannel) /* 173 */ /* Slot 174 is reserved */ /* Slot 175 is reserved */ #define Tcl_GetVar2 \ (tclStubsPtr->tcl_GetVar2) /* 176 */ /* Slot 177 is reserved */ |
| ︙ | ︙ | |||
3911 3912 3913 3914 3915 3916 3917 3918 3919 | #define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0) #if defined(USE_TCL_STUBS) && (TCL_UTF_MAX <= 3) # undef Tcl_UtfCharComplete # define Tcl_UtfCharComplete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \ ? ((length) >= TCL_UTF_MAX) : tclStubsPtr->tcl_UtfCharComplete((src), (length))) #endif #endif /* _TCLDECLS */ | > > > > > | 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 | #define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0) #if defined(USE_TCL_STUBS) && (TCL_UTF_MAX <= 3) # undef Tcl_UtfCharComplete # define Tcl_UtfCharComplete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \ ? ((length) >= TCL_UTF_MAX) : tclStubsPtr->tcl_UtfCharComplete((src), (length))) #endif #ifndef TCL_NO_DEPRECATED # define Tcl_CreateSlave Tcl_CreateChild # define Tcl_GetSlave Tcl_GetChild # define Tcl_GetMaster Tcl_GetParent #endif #endif /* _TCLDECLS */ |
Changes to generic/tclEncoding.c.
| ︙ | ︙ | |||
112 113 114 115 116 117 118 |
* conversion. */
char prefixBytes[256]; /* If a byte in the input stream is the first
* character of one of the escape sequences in
* the following array, the corresponding
* entry in this array is 1, otherwise it is
* 0. */
int numSubTables; /* Length of following array. */
| | | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 |
* conversion. */
char prefixBytes[256]; /* If a byte in the input stream is the first
* character of one of the escape sequences in
* the following array, the corresponding
* entry in this array is 1, otherwise it is
* 0. */
int numSubTables; /* Length of following array. */
EscapeSubTable subTables[TCLFLEXARRAY];/* Information about each EscapeSubTable used
* by this encoding type. The actual size is
* as large as necessary to hold all
* EscapeSubTables. */
} EscapeEncodingData;
/*
* Constants used when loading an encoding file to identify the type of the
|
| ︙ | ︙ | |||
1988 1989 1990 1991 1992 1993 1994 |
Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est));
}
}
Tcl_Free((void *)argv);
Tcl_DStringFree(&lineString);
}
| | | 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 |
Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est));
}
}
Tcl_Free((void *)argv);
Tcl_DStringFree(&lineString);
}
size = offsetof(EscapeEncodingData, subTables)
+ Tcl_DStringLength(&escapeData);
dataPtr = (EscapeEncodingData *)Tcl_Alloc(size);
dataPtr->initLen = strlen(init);
memcpy(dataPtr->init, init, dataPtr->initLen + 1);
dataPtr->finalLen = strlen(final);
memcpy(dataPtr->final, final, dataPtr->finalLen + 1);
dataPtr->numSubTables =
|
| ︙ | ︙ |
Changes to generic/tclEnsemble.c.
| ︙ | ︙ | |||
3158 3159 3160 3161 3162 3163 3164 |
goto cleanup;
}
ensemble = (Tcl_Command) cmdPtr;
goto checkNextWord;
}
/*
| | | 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 |
goto cleanup;
}
ensemble = (Tcl_Command) cmdPtr;
goto checkNextWord;
}
/*
* 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.
*/
invokeAnyway = 1;
if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, depth, cmdPtr,
|
| ︙ | ︙ | |||
3258 3259 3260 3261 3262 3263 3264 |
if (cmdPtr->compileProc == NULL) {
return TCL_ERROR;
}
/*
* Advance parsePtr->tokenPtr so that it points at the last subcommand.
| | | | | 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 |
if (cmdPtr->compileProc == NULL) {
return TCL_ERROR;
}
/*
* 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 need to
* allocate a synthetic Tcl_Parse struct or copy tokens around.
*/
for (i = 0; i < depth - 1; i++) {
parsePtr->tokenPtr = TokenAfter(parsePtr->tokenPtr);
}
parsePtr->numWords -= (depth - 1);
|
| ︙ | ︙ |
Changes to generic/tclEvent.c.
| ︙ | ︙ | |||
296 297 298 299 300 301 302 | * Depends on what actions the "bgerror" command takes for the errors. * *---------------------------------------------------------------------- */ int TclDefaultBgErrorHandlerObjCmd( | | | 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 |
* Depends on what actions the "bgerror" command takes for the errors.
*
*----------------------------------------------------------------------
*/
int
TclDefaultBgErrorHandlerObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *keyPtr, *valuePtr;
Tcl_Obj *tempObjv[2];
int result, code, level;
|
| ︙ | ︙ | |||
1040 1041 1042 1043 1044 1045 1046 | /* * Initialize locks used by the memory allocators before anything * interesting happens so we can use the allocators in the * implementation of self-initializing locks. */ | | | 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 | /* * Initialize locks used by the memory allocators before anything * interesting happens so we can use the allocators in the * implementation of self-initializing locks. */ TclInitThreadStorage(); /* Creates hash table for * thread local storage */ #if USE_TCLALLOC TclInitAlloc(); /* Process wide mutex init */ #endif #if TCL_THREADS && defined(USE_THREAD_ALLOC) TclInitThreadAlloc(); /* Setup thread allocator caches */ #endif |
| ︙ | ︙ | |||
1158 1159 1160 1161 1162 1163 1164 |
* Finalizing the filesystem must come after anything which might
* conceivably interact with the 'Tcl_FS' API.
*/
TclFinalizeFilesystem();
/*
| | | 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 |
* Finalizing the filesystem must come after anything which might
* conceivably interact with the 'Tcl_FS' API.
*/
TclFinalizeFilesystem();
/*
* 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.
*
* Note in particular that TclFinalizeObjects() must follow
* TclFinalizeFilesystem() because TclFinalizeFilesystem free's the
* Tcl_Obj that holds the path of the current working directory.
*/
|
| ︙ | ︙ | |||
1393 1394 1395 1396 1397 1398 1399 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_VwaitObjCmd( | | | 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_VwaitObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int done, foundEvent;
const char *nameString;
|
| ︙ | ︙ | |||
1489 1490 1491 1492 1493 1494 1495 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_UpdateObjCmd( | | | 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_UpdateObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int optionIndex;
int flags = 0; /* Initialized to avoid compiler warning. */
static const char *const updateOptions[] = {"idletasks", NULL};
|
| ︙ | ︙ |
Changes to generic/tclExecute.c.
| ︙ | ︙ | |||
793 794 795 796 797 798 799 |
TclCreateExecEnv(
Tcl_Interp *interp, /* Interpreter for which the execution
* environment is being created. */
size_t size) /* The initial stack size, in number of words
* [sizeof(Tcl_Obj*)] */
{
ExecEnv *eePtr = (ExecEnv *)Tcl_Alloc(sizeof(ExecEnv));
| | | | 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 |
TclCreateExecEnv(
Tcl_Interp *interp, /* Interpreter for which the execution
* environment is being created. */
size_t size) /* The initial stack size, in number of words
* [sizeof(Tcl_Obj*)] */
{
ExecEnv *eePtr = (ExecEnv *)Tcl_Alloc(sizeof(ExecEnv));
ExecStack *esPtr = (ExecStack *)Tcl_Alloc(offsetof(ExecStack, stackWords)
+ size * sizeof(Tcl_Obj *));
eePtr->execStackPtr = esPtr;
TclNewIntObj(eePtr->constants[0], 0);
Tcl_IncrRefCount(eePtr->constants[0]);
TclNewIntObj(eePtr->constants[1], 1);
Tcl_IncrRefCount(eePtr->constants[1]);
eePtr->interp = interp;
|
| ︙ | ︙ | |||
1059 1060 1061 1062 1063 1064 1065 |
while (needed > newElems) {
newElems *= 2;
}
#else
newElems = needed;
#endif
| | | 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 |
while (needed > newElems) {
newElems *= 2;
}
#else
newElems = needed;
#endif
newBytes = offsetof(ExecStack, stackWords) + newElems * sizeof(Tcl_Obj *);
oldPtr = esPtr;
esPtr = (ExecStack *)Tcl_Alloc(newBytes);
oldPtr->nextPtr = esPtr;
esPtr->prevPtr = oldPtr;
esPtr->nextPtr = NULL;
|
| ︙ | ︙ | |||
4250 4251 4252 4253 4254 4255 4256 |
NEXT_INST_F(1, 0, 1);
}
break;
case INST_COROUTINE_NAME: {
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
TclNewObj(objResultPtr);
| | | 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 |
NEXT_INST_F(1, 0, 1);
}
break;
case INST_COROUTINE_NAME: {
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
TclNewObj(objResultPtr);
if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) {
Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr,
objResultPtr);
}
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
}
break;
|
| ︙ | ︙ | |||
4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 |
TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr);
NEXT_INST_F(1, 1, 1);
case INST_ORIGIN_COMMAND:
TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
if (cmd == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", TclGetString(OBJ_AT_TOS)));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
TclGetString(OBJ_AT_TOS), NULL);
CACHE_STACK_INFO();
TRACE_APPEND(("ERROR: not command\n"));
goto gotError;
}
| > > > > > > > > > > > > < < < < < < | 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 |
TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr);
NEXT_INST_F(1, 1, 1);
case INST_ORIGIN_COMMAND:
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();
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
TclGetString(OBJ_AT_TOS), NULL);
CACHE_STACK_INFO();
TRACE_APPEND(("ERROR: not command\n"));
goto gotError;
}
TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS)));
NEXT_INST_F(1, 1, 1);
}
/*
* -----------------------------------------------------------------
* Start of TclOO support instructions.
|
| ︙ | ︙ | |||
4643 4644 4645 4646 4647 4648 4649 |
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
/*
* Extract the desired list element.
*/
if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK)
| | > > > | > | | | | | > > | 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 |
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
/*
* Extract the desired list element.
*/
if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK)
&& !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);
if (!objResultPtr) {
TRACE_ERROR(interp);
goto gotError;
}
|
| ︙ | ︙ | |||
5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 |
TRACE(("\"%.20s\" %.20s => ", O2S(valuePtr), O2S(value2Ptr)));
/*
* Get char length to calulate what 'end' means.
*/
slength = Tcl_GetCharLength(valuePtr);
if (TclGetIntForIndexM(interp, value2Ptr, slength-1, &index)!=TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (index >= slength) {
TclNewObj(objResultPtr);
} else if (TclIsPureByteArray(valuePtr)) {
objResultPtr = Tcl_NewByteArrayObj(
Tcl_GetByteArrayFromObj(valuePtr, NULL)+index, 1);
} else if (valuePtr->bytes && slength == valuePtr->length) {
| > > > | 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 |
TRACE(("\"%.20s\" %.20s => ", O2S(valuePtr), O2S(value2Ptr)));
/*
* Get char length to calulate what 'end' means.
*/
slength = Tcl_GetCharLength(valuePtr);
DECACHE_STACK_INFO();
if (TclGetIntForIndexM(interp, value2Ptr, slength-1, &index)!=TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
CACHE_STACK_INFO();
if (index >= slength) {
TclNewObj(objResultPtr);
} else if (TclIsPureByteArray(valuePtr)) {
objResultPtr = Tcl_NewByteArrayObj(
Tcl_GetByteArrayFromObj(valuePtr, NULL)+index, 1);
} else if (valuePtr->bytes && slength == valuePtr->length) {
|
| ︙ | ︙ | |||
5124 5125 5126 5127 5128 5129 5130 5131 |
TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_STR_RANGE:
TRACE(("\"%.20s\" %.20s %.20s =>",
O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS)));
slength = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1;
if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, slength,
| > > | > > > > | > > | 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 |
TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_STR_RANGE:
TRACE(("\"%.20s\" %.20s %.20s =>",
O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS)));
slength = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1;
DECACHE_STACK_INFO();
if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, slength,
&fromIdx) != TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
if (TclGetIntForIndexM(interp, OBJ_AT_TOS, slength,
&toIdx) != TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
CACHE_STACK_INFO();
if (fromIdx == TCL_INDEX_NONE) {
fromIdx = TCL_INDEX_START;
}
if (toIdx + 1 >= slength + 1) {
toIdx = slength;
}
|
| ︙ | ︙ | |||
5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 |
case INST_STR_REPLACE:
value3Ptr = POP_OBJECT();
valuePtr = OBJ_AT_DEPTH(2);
slength = Tcl_GetCharLength(valuePtr) - 1;
TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr),
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr)));
if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, slength,
&fromIdx) != TCL_OK
|| TclGetIntForIndexM(interp, OBJ_AT_TOS, slength,
&toIdx) != TCL_OK) {
TclDecrRefCount(value3Ptr);
TRACE_ERROR(interp);
goto gotError;
}
TclDecrRefCount(OBJ_AT_TOS);
(void) POP_OBJECT();
TclDecrRefCount(OBJ_AT_TOS);
(void) POP_OBJECT();
if ((toIdx == TCL_INDEX_NONE) ||
(fromIdx + 1 > slength + 1) ||
| > > > | 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 |
case INST_STR_REPLACE:
value3Ptr = POP_OBJECT();
valuePtr = OBJ_AT_DEPTH(2);
slength = 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, slength,
&fromIdx) != TCL_OK
|| TclGetIntForIndexM(interp, OBJ_AT_TOS, slength,
&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);
(void) POP_OBJECT();
if ((toIdx == TCL_INDEX_NONE) ||
(fromIdx + 1 > slength + 1) ||
|
| ︙ | ︙ |
Changes to generic/tclFCmd.c.
| ︙ | ︙ | |||
1081 1082 1083 1084 1085 1086 1087 | "bad option \"%s\", there are no file attributes in this" " filesystem", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); goto end; } if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, | | | 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 |
"bad option \"%s\", there are no file attributes in this"
" filesystem", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
goto end;
}
if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
"option", TCL_INDEX_TEMP_TABLE, &index) != TCL_OK) {
goto end;
}
if (Tcl_FSFileAttrsGet(interp, index, filePtr,
&objPtr) != TCL_OK) {
goto end;
}
Tcl_SetObjResult(interp, objPtr);
|
| ︙ | ︙ | |||
1106 1107 1108 1109 1110 1111 1112 |
" filesystem", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
goto end;
}
for (i = 0; i < objc ; i += 2) {
if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
| | | 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 |
" filesystem", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
goto end;
}
for (i = 0; i < objc ; i += 2) {
if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
"option", TCL_INDEX_TEMP_TABLE, &index) != TCL_OK) {
goto end;
}
if (i + 1 == objc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"value for \"%s\" missing", TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR",
"NOVALUE", NULL);
|
| ︙ | ︙ |
Changes to generic/tclIO.h.
| ︙ | ︙ | |||
40 41 42 43 44 45 46 |
int nextAdded; /* The next position into which a character
* will be put in the buffer. */
int nextRemoved; /* Position of next byte to be removed from
* the buffer. */
int bufLength; /* How big is the buffer? */
struct ChannelBuffer *nextPtr;
/* Next buffer in chain. */
| | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 |
int nextAdded; /* The next position into which a character
* will be put in the buffer. */
int nextRemoved; /* Position of next byte to be removed from
* the buffer. */
int bufLength; /* How big is the buffer? */
struct ChannelBuffer *nextPtr;
/* Next buffer in chain. */
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. */
} ChannelBuffer;
#define CHANNELBUFFER_HEADER_SIZE offsetof(ChannelBuffer, buf)
|
| ︙ | ︙ |
Changes to generic/tclIOUtil.c.
| ︙ | ︙ | |||
2694 2695 2696 2697 2698 2699 2700 | * Threading issue: Multiple threads at system startup could in * principle call this function simultaneously. They will * therefore each set the cwdPathPtr independently, which is a * bit peculiar, but should be fine. Once we have a cwd, we'll * always be in the 'else' branch below which is simpler. */ | | | 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 |
* Threading issue: Multiple threads at system startup could in
* principle call this function simultaneously. They will
* therefore each set the cwdPathPtr independently, which is a
* bit peculiar, but should be fine. Once we have a cwd, we'll
* always be in the 'else' branch below which is simpler.
*/
void *cd = (void *) Tcl_FSGetNativePath(norm);
FsUpdateCwd(norm, TclNativeDupInternalRep(cd));
Tcl_DecrRefCount(norm);
}
Tcl_DecrRefCount(retVal);
} else {
/*
|
| ︙ | ︙ | |||
4485 4486 4487 4488 4489 4490 4491 |
* Avoid possible segfaults or nondeterministic memory leaks where the
* reference count has been incorreclty managed.
*/
Tcl_Panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0");
return NULL;
}
| | | 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 |
* Avoid possible segfaults or nondeterministic memory leaks where the
* reference count has been incorreclty managed.
*/
Tcl_Panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0");
return NULL;
}
/* Start with an up-to-date copy of the filesystem. */
fsRecPtr = FsGetFirstFilesystem();
Claim();
/*
* Ensure that pathPtr is a valid pathname.
*/
if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) {
|
| ︙ | ︙ |
Changes to generic/tclIndexObj.c.
| ︙ | ︙ | |||
143 144 145 146 147 148 149 |
}
tablePtr[t] = TclGetString(objv[t]);
}
tablePtr[objc] = NULL;
result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr,
| | | 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 |
}
tablePtr[t] = TclGetString(objv[t]);
}
tablePtr[objc] = NULL;
result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr,
sizeof(char *), msg, flags | TCL_INDEX_TEMP_TABLE, indexPtr);
Tcl_Free((void *)tablePtr);
return result;
}
/*
|
| ︙ | ︙ | |||
207 208 209 210 211 212 213 |
if (offset+1 <= sizeof(char *)) {
offset = sizeof(char *);
}
/*
* See if there is a valid cached result from a previous lookup.
*/
| | | 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 |
if (offset+1 <= sizeof(char *)) {
offset = sizeof(char *);
}
/*
* See if there is a valid cached result from a previous lookup.
*/
if (!(flags & TCL_INDEX_TEMP_TABLE)) {
irPtr = TclFetchIntRep(objPtr, &indexType);
if (irPtr) {
indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
*indexPtr = indexRep->index;
return TCL_OK;
}
|
| ︙ | ︙ | |||
271 272 273 274 275 276 277 |
done:
/*
* Cache the found representation. Note that we want to avoid allocating a
* new internal-rep if at all possible since that is potentially a slow
* operation.
*/
| | | 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 |
done:
/*
* Cache the found representation. Note that we want to avoid allocating a
* new internal-rep if at all possible since that is potentially a slow
* operation.
*/
if (!(flags & TCL_INDEX_TEMP_TABLE)) {
irPtr = TclFetchIntRep(objPtr, &indexType);
if (irPtr) {
indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
} else {
Tcl_ObjIntRep ir;
indexRep = (IndexRep*)Tcl_Alloc(sizeof(IndexRep));
|
| ︙ | ︙ |
Changes to generic/tclInt.h.
| ︙ | ︙ | |||
905 906 907 908 909 910 911 912 913 914 915 916 917 918 | /* *---------------------------------------------------------------- * Data structures related to procedures. These are used primarily in * tclProc.c, tclCompile.c, and tclExecute.c. *---------------------------------------------------------------- */ /* * Forward declaration to prevent an error when the forward reference to * Command is encountered in the Proc and ImportRef types declared below. */ struct Command; | > > > > > > | 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 | /* *---------------------------------------------------------------- * Data structures related to procedures. These are used primarily in * tclProc.c, tclCompile.c, and tclExecute.c. *---------------------------------------------------------------- */ #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. */ struct Command; |
| ︙ | ︙ | |||
948 949 950 951 952 953 954 |
Tcl_ResolvedVarInfo *resolveInfo;
/* Customized variable resolution info
* supplied by the Tcl_ResolveCompiledVarProc
* associated with a namespace. Each variable
* is marked by a unique tag during
* compilation, and that same tag is used to
* find the variable at runtime. */
| | | 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 |
Tcl_ResolvedVarInfo *resolveInfo;
/* Customized variable resolution info
* supplied by the Tcl_ResolveCompiledVarProc
* associated with a namespace. Each variable
* is marked by a unique tag during
* compilation, and that same tag is used to
* find the variable at runtime. */
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
* FIELD IN THE STRUCTURE! */
} CompiledLocal;
/*
|
| ︙ | ︙ | |||
1286 1287 1288 1289 1290 1291 1292 |
*/
#define CLL_END (-1)
typedef struct ContLineLoc {
int num; /* Number of entries in loc, not counting the
* final -1 marker entry. */
| | | 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 |
*/
#define CLL_END (-1)
typedef struct ContLineLoc {
int num; /* Number of entries in loc, not counting the
* final -1 marker entry. */
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
* value -1 is put after the last location, as
* end-marker/sentinel. */
} ContLineLoc;
|
| ︙ | ︙ | |||
1435 1436 1437 1438 1439 1440 1441 |
typedef struct ExecStack {
struct ExecStack *prevPtr;
struct ExecStack *nextPtr;
Tcl_Obj **markerPtr;
Tcl_Obj **endPtr;
Tcl_Obj **tosPtr;
| | | 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 |
typedef struct ExecStack {
struct ExecStack *prevPtr;
struct ExecStack *nextPtr;
Tcl_Obj **markerPtr;
Tcl_Obj **endPtr;
Tcl_Obj **tosPtr;
Tcl_Obj *stackWords[TCLFLEXARRAY];
} ExecStack;
/*
* The data structure defining the execution environment for ByteCode's.
* There is one ExecEnv structure per Tcl interpreter. It holds the evaluation
* stack that holds command operands and results. The stack grows towards
* increasing addresses. The member stackPtr points to the stackItems of the
|
| ︙ | ︙ | |||
1687 1688 1689 1690 1691 1692 1693 |
* command. */
Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */
} Command;
/*
* Flag bits for commands.
*
| | | | | | | 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 |
* command. */
Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */
} Command;
/*
* Flag bits for commands.
*
* 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 - 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 - 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 - 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
* recursive renames will not be traced.
* TCL_TRACE_DELETE - A delete trace is in progress. Further
* recursive deletes will not be traced.
* (these last two flags are defined in tcl.h)
*/
#define CMD_DYING 0x01
#define CMD_TRACE_ACTIVE 0x02
#define CMD_HAS_EXEC_TRACES 0x04
#define CMD_COMPILES_EXPANDED 0x08
#define CMD_REDEF_IN_PROGRESS 0x10
#define CMD_VIA_RESOLVER 0x20
#define CMD_DEAD 0x40
|
| ︙ | ︙ | |||
2538 2539 2540 2541 2542 2543 2544 |
Tcl_Obj *fileName, Tcl_Obj *attrObjPtr);
typedef struct TclFileAttrProcs {
TclGetFileAttrProc *getProc;/* The procedure for getting attrs. */
TclSetFileAttrProc *setProc;/* The procedure for setting attrs. */
} TclFileAttrProcs;
| < < < < < < < < < | 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 |
Tcl_Obj *fileName, Tcl_Obj *attrObjPtr);
typedef struct TclFileAttrProcs {
TclGetFileAttrProc *getProc;/* The procedure for getting attrs. */
TclSetFileAttrProc *setProc;/* The procedure for setting attrs. */
} TclFileAttrProcs;
/*
* Opaque handle used in pipeline routines to encapsulate platform-dependent
* state.
*/
typedef struct TclFile_ *TclFile;
|
| ︙ | ︙ | |||
4103 4104 4105 4106 4107 4108 4109 | /* * Just for the purposes of command-type registration. */ MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd; MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclLocalAliasObjCmd; | | | 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 | /* * Just for the purposes of command-type registration. */ MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd; MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclLocalAliasObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclChildObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInvokeImportedCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOPublicObjectCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOPrivateObjectCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOMyClassObjCmd; /* * TIP #462. |
| ︙ | ︙ | |||
4906 4907 4908 4909 4910 4911 4912 | /* *---------------------------------------------------------------- * Inline version of TclCleanupCommand; still need the function as it is in * the internal stubs, but the core can use the macro instead. */ | | > | | > > | > > > > > > > > > > > > > > > > > | 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 |
/*
*----------------------------------------------------------------
* Inline version of TclCleanupCommand; still need the function as it is in
* the internal stubs, but the core can use the macro instead.
*/
#define TclCleanupCommandMacro(cmdPtr) \
do { \
if ((cmdPtr)->refCount-- <= 1) { \
Tcl_Free(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) { \
Tcl_Free(((location))); \
} \
(location) = (cmdPtr); \
} while (0)
#define TclRoutineHasName(cmdPtr) \
((cmdPtr)->hPtr != NULL)
/*
*----------------------------------------------------------------
* Inline versions of Tcl_LimitReady() and Tcl_LimitExceeded to limit number
* of calls out of the critical path. Note that this code isn't particularly
* readable; the non-inline version (in tclInterp.c) is much easier to
* understand. Note also that these macros takes different args (iPtr->limit)
|
| ︙ | ︙ |
Changes to generic/tclInterp.c.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 | /* Forward declaration */ struct Target; /* * Alias: * | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 |
/* Forward declaration */
struct Target;
/*
* Alias:
*
* 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 {
Tcl_Obj *token; /* Token for the alias command in the child
* interp. This used to be the command name in
* the child when the alias was first
* created. */
Tcl_Interp *targetInterp; /* Interp in which target command will be
* invoked. */
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 child.
* This is used by alias deletion to remove
* the alias from the child interpreter alias
* table. */
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 child interp
* will be appended to the prefix before the
* command is invoked. */
Tcl_Obj *objPtr; /* The first actual prefix object - the target
* command name; this has to be at the end of
* the structure, which will be extended to
* accomodate the remaining objects in the
* prefix. */
} Alias;
/*
*
* Child:
*
* 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 {
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 *childInterp; /* The child interpreter. */
Tcl_Command interpCmd; /* Interpreter object command. */
Tcl_HashTable aliasTable; /* Table which maps from names of commands in
* child interpreter to struct Alias defined
* below. */
} Child;
/*
* struct Target:
*
* 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 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 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
* if at the start of the list of targets. */
} Target;
/*
* Parent:
*
* 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 interpreters and can
* only load safe extensions.
*/
typedef struct {
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
* children or sibling interpreters that direct
* to commands in this interpreter. This list
* is used to remove dangling pointers from
* the child (or sibling) interpreters when
* this interpreter is deleted. */
} Parent;
/*
* The following structure keeps track of all the Parent and Child information
* on a per-interp basis.
*/
typedef struct {
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;
/*
* Limit callbacks handled by scripts are modelled as structures which are
* stored in hashes indexed by a two-word key. Note that the type of the
* 'type' field in the key is not int; this is to make sure that things are
* likely to work properly on 64-bit architectures.
|
| ︙ | ︙ | |||
210 211 212 213 214 215 216 | /* * Prototypes for local static functions: */ static int AliasCreate(Tcl_Interp *interp, | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 | /* * Prototypes for local static functions: */ static int AliasCreate(Tcl_Interp *interp, 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 *childInterp, Tcl_Obj *namePtr); static int AliasDescribe(Tcl_Interp *interp, 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 ChildBgerror(Tcl_Interp *interp, Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); static Tcl_Interp * ChildCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr, int safe); static int ChildDebugCmd(Tcl_Interp *interp, Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); static int ChildEval(Tcl_Interp *interp, Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); static int ChildExpose(Tcl_Interp *interp, Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); static int ChildHide(Tcl_Interp *interp, Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); 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 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 ChildCommandLimitCmd(Tcl_Interp *interp, Tcl_Interp *childInterp, int consumedObjc, int objc, Tcl_Obj *const objv[]); static int ChildTimeLimitCmd(Tcl_Interp *interp, Tcl_Interp *childInterp, int consumedObjc, int objc, Tcl_Obj *const objv[]); 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, Tcl_Interp *interp); static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); /* NRE enabling */ static Tcl_NRPostProc NRPostInvokeHidden; static Tcl_ObjCmdProc NRInterpCmd; static Tcl_ObjCmdProc NRChildCmd; /* *---------------------------------------------------------------------- * * TclSetPreInitScript -- * |
| ︙ | ︙ | |||
457 458 459 460 461 462 463 | } /* *--------------------------------------------------------------------------- * * TclInterpInit -- * | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 |
}
/*
*---------------------------------------------------------------------------
*
* TclInterpInit --
*
* Initializes the invoking interpreter for using the parent, child and
* safe interp facilities. This is called from inside Tcl_CreateInterp().
*
* Results:
* Always returns TCL_OK for backwards compatibility.
*
* Side effects:
* Adds the "interp" command to an interpreter and initializes the
* interpInfoPtr field of the invoking interpreter.
*
*---------------------------------------------------------------------------
*/
int
TclInterpInit(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
InterpInfo *interpInfoPtr;
Parent *parentPtr;
Child *childPtr;
interpInfoPtr = (InterpInfo *)Tcl_Alloc(sizeof(InterpInfo));
((Interp *) interp)->interpInfo = interpInfoPtr;
parentPtr = &interpInfoPtr->parent;
Tcl_InitHashTable(&parentPtr->childTable, TCL_STRING_KEYS);
parentPtr->targetsPtr = NULL;
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);
Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* InterpInfoDeleteProc --
*
* Invoked when an interpreter is being deleted. It releases all storage
* used by the parent/child/safe interpreter facilities.
*
* Results:
* None.
*
* Side effects:
* Cleans up storage. Sets the interpInfoPtr field of the interp to NULL.
*
*---------------------------------------------------------------------------
*/
static void
InterpInfoDeleteProc(
TCL_UNUSED(void *),
Tcl_Interp *interp) /* Interp being deleted. All commands for
* child interps should already be deleted. */
{
InterpInfo *interpInfoPtr;
Child *childPtr;
Parent *parentPtr;
Target *targetPtr;
interpInfoPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
/*
* There shouldn't be any commands left.
*/
parentPtr = &interpInfoPtr->parent;
if (parentPtr->childTable.numEntries != 0) {
Tcl_Panic("InterpInfoDeleteProc: still exist commands");
}
Tcl_DeleteHashTable(&parentPtr->childTable);
/*
* Tell any interps that have aliases to this interp that they should
* delete those aliases. If the other interp was already dead, it would
* have removed the target record already.
*/
for (targetPtr = parentPtr->targetsPtr; targetPtr != NULL; ) {
Target *tmpPtr = targetPtr->nextPtr;
Tcl_DeleteCommandFromToken(targetPtr->childInterp,
targetPtr->childCmd);
targetPtr = tmpPtr;
}
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 parent.
* First ensure that the cleanup callback doesn't try to delete the
* interp again.
*/
childPtr->childInterp = NULL;
Tcl_DeleteCommandFromToken(childPtr->parentInterp,
childPtr->interpCmd);
}
/*
* There shouldn't be any aliases left.
*/
if (childPtr->aliasTable.numEntries != 0) {
Tcl_Panic("InterpInfoDeleteProc: still exist aliases");
}
Tcl_DeleteHashTable(&childPtr->aliasTable);
Tcl_Free(interpInfoPtr);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
607 608 609 610 611 612 613 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv);
}
static int
NRInterpCmd(
| | | | > > > | | > > > | | | | | | | | | | | | | | | | | 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv);
}
static int
NRInterpCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *childInterp;
int index;
static const char *const options[] = {
"alias", "aliases", "bgerror", "cancel",
"children", "create", "debug", "delete",
"eval", "exists", "expose",
"hide", "hidden", "issafe",
"invokehidden", "limit", "marktrusted", "recursionlimit",
#ifndef TCL_NO_DEPRECATED
"slaves",
#endif
"share", "target", "transfer",
NULL
};
enum option {
OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL,
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,
#ifndef TCL_NO_DEPRECATED
OPT_SLAVES,
#endif
OPT_SHARE, 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) {
return TCL_ERROR;
}
switch ((enum option) index) {
case OPT_ALIAS: {
Tcl_Interp *parentInterp;
if (objc < 4) {
aliasArgs:
Tcl_WrongNumArgs(interp, 2, objv,
"childPath childCmd ?parentPath parentCmd? ?arg ...?");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
if (objc == 4) {
return AliasDescribe(interp, childInterp, objv[3]);
}
if ((objc == 5) && (TclGetString(objv[4])[0] == '\0')) {
return AliasDelete(interp, childInterp, objv[3]);
}
if (objc > 5) {
parentInterp = GetInterp(interp, objv[4]);
if (parentInterp == NULL) {
return TCL_ERROR;
}
return AliasCreate(interp, childInterp, parentInterp, objv[3],
objv[5], objc - 6, objv + 6);
}
goto aliasArgs;
}
case OPT_ALIASES:
childInterp = GetInterp2(interp, objc, objv);
if (childInterp == NULL) {
return TCL_ERROR;
}
return AliasList(interp, childInterp);
case OPT_BGERROR:
if (objc != 3 && objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
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 {
|
| ︙ | ︙ | |||
730 731 732 733 734 735 736 |
if (i < objc - 2) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-unwind? ?--? ?path? ?result?");
return TCL_ERROR;
}
/*
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 |
if (i < objc - 2) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-unwind? ?--? ?path? ?result?");
return TCL_ERROR;
}
/*
* Did they specify a child interp to cancel the script in progress
* in? If not, use the current interp.
*/
if (i < objc) {
childInterp = GetInterp(interp, objv[i]);
if (childInterp == NULL) {
return TCL_ERROR;
}
i++;
} else {
childInterp = interp;
}
if (i < objc) {
resultObjPtr = objv[i];
/*
* Tcl_CancelEval removes this reference.
*/
Tcl_IncrRefCount(resultObjPtr);
i++;
} else {
resultObjPtr = NULL;
}
return Tcl_CancelEval(childInterp, resultObjPtr, 0, flags);
}
case OPT_CREATE: {
int i, last, safe;
Tcl_Obj *childPtr;
char buf[16 + TCL_INTEGER_SPACE];
static const char *const createOptions[] = {
"-safe", "--", NULL
};
enum option {
OPT_SAFE, OPT_LAST
};
safe = Tcl_IsSafe(interp);
/*
* Weird historical rules: "-safe" is accepted at the end, too.
*/
childPtr = NULL;
last = 0;
for (i = 2; i < objc; i++) {
if ((last == 0) && (TclGetString(objv[i])[0] == '-')) {
if (Tcl_GetIndexFromObj(interp, objv[i], createOptions,
"option", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
if (index == OPT_SAFE) {
safe = 1;
continue;
}
i++;
last = 1;
}
if (childPtr != NULL) {
Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
return TCL_ERROR;
}
if (i < objc) {
childPtr = objv[i];
}
}
buf[0] = '\0';
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 parent interpreter.
*/
for (i = 0; ; i++) {
Tcl_CmdInfo cmdInfo;
sprintf(buf, "interp%d", i);
if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) {
break;
}
}
childPtr = Tcl_NewStringObj(buf, -1);
}
if (ChildCreate(interp, childPtr, safe) == NULL) {
if (buf[0] != '\0') {
Tcl_DecrRefCount(childPtr);
}
return TCL_ERROR;
}
Tcl_SetObjResult(interp, childPtr);
return TCL_OK;
}
case OPT_DEBUG: /* TIP #378 */
/*
* Currently only -frame supported, otherwise ?-option ?value??
*/
if (objc < 3 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildDebugCmd(interp, childInterp, objc - 3, objv + 3);
case OPT_DELETE: {
int i;
InterpInfo *iiPtr;
for (i = 2; i < objc; i++) {
childInterp = GetInterp(interp, objv[i]);
if (childInterp == NULL) {
return TCL_ERROR;
} 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 *) childInterp)->interpInfo;
Tcl_DeleteCommandFromToken(iiPtr->child.parentInterp,
iiPtr->child.interpCmd);
}
return TCL_OK;
}
case OPT_EVAL:
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildEval(interp, childInterp, objc - 3, objv + 3);
case OPT_EXISTS: {
int exists = 1;
childInterp = GetInterp2(interp, objc, objv);
if (childInterp == NULL) {
if (objc > 3) {
return TCL_ERROR;
}
Tcl_ResetResult(interp);
exists = 0;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists));
return TCL_OK;
}
case OPT_EXPOSE:
if ((objc < 4) || (objc > 5)) {
Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
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;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildHide(interp, childInterp, objc - 3, objv + 3);
case OPT_HIDDEN:
childInterp = GetInterp2(interp, objc, objv);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildHidden(interp, childInterp);
case OPT_ISSAFE:
childInterp = GetInterp2(interp, objc, objv);
if (childInterp == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(childInterp)));
return TCL_OK;
case OPT_INVOKEHID: {
int i;
const char *namespaceName;
static const char *const hiddenOptions[] = {
"-global", "-namespace", "--", NULL
};
|
| ︙ | ︙ | |||
956 957 958 959 960 961 962 |
}
}
if (objc - i < 1) {
Tcl_WrongNumArgs(interp, 2, objv,
"path ?-namespace ns? ?-global? ?--? cmd ?arg ..?");
return TCL_ERROR;
}
| | | | | | | | | | | | | | > | > > | | | | | | | | | | | | | | | | | | | | 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 |
}
}
if (objc - i < 1) {
Tcl_WrongNumArgs(interp, 2, objv,
"path ?-namespace ns? ?-global? ?--? cmd ?arg ..?");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildInvokeHidden(interp, childInterp, namespaceName, objc - i,
objv + i);
}
case OPT_LIMIT: {
static const char *const limitTypes[] = {
"commands", "time", NULL
};
enum LimitTypes {
LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME
};
int limitType;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv,
"path limitType ?-option value ...?");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", 0,
&limitType) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum LimitTypes) limitType) {
case LIMIT_TYPE_COMMANDS:
return ChildCommandLimitCmd(interp, childInterp, 4, objc,objv);
case LIMIT_TYPE_TIME:
return ChildTimeLimitCmd(interp, childInterp, 4, objc, objv);
}
}
break;
case OPT_MARKTRUSTED:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "path");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildMarkTrusted(interp, childInterp);
case OPT_RECLIMIT:
if (objc != 3 && objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildRecursionLimit(interp, childInterp, objc - 3, objv + 3);
#ifndef TCL_NO_DEPRECATED
case OPT_SLAVES:
#endif
case OPT_CHILDREN: {
InterpInfo *iiPtr;
Tcl_Obj *resultPtr;
Tcl_HashEntry *hPtr;
Tcl_HashSearch hashSearch;
char *string;
childInterp = GetInterp2(interp, objc, objv);
if (childInterp == NULL) {
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo;
resultPtr = Tcl_NewObj();
hPtr = Tcl_FirstHashEntry(&iiPtr->parent.childTable, &hashSearch);
for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
string = (char *)Tcl_GetHashKey(&iiPtr->parent.childTable, hPtr);
Tcl_ListObjAppendElement(NULL, resultPtr,
Tcl_NewStringObj(string, -1));
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
case OPT_TRANSFER:
case OPT_SHARE: {
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;
}
parentInterp = GetInterp(interp, objv[2]);
if (parentInterp == NULL) {
return TCL_ERROR;
}
chan = Tcl_GetChannel(parentInterp, TclGetString(objv[3]), NULL);
if (chan == NULL) {
Tcl_TransferResult(parentInterp, TCL_OK, interp);
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[4]);
if (childInterp == NULL) {
return TCL_ERROR;
}
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(parentInterp, chan) != TCL_OK) {
Tcl_TransferResult(parentInterp, TCL_OK, interp);
return TCL_ERROR;
}
}
return TCL_OK;
}
case OPT_TARGET: {
InterpInfo *iiPtr;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
const char *aliasName;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "path alias");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
aliasName = TclGetString(objv[3]);
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",
aliasName, TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName,
NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1163 1164 1165 1166 1167 1168 1169 | * * Creates an alias between two interpreters. * * Results: * A standard Tcl result. * * Side effects: | | | | | | | | | | | | 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 |
*
* Creates an alias between two interpreters.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates a new alias, manipulates the result field of childInterp.
*
*----------------------------------------------------------------------
*/
int
Tcl_CreateAlias(
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 *childObjPtr, *targetObjPtr;
Tcl_Obj **objv;
int i;
int result;
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]);
}
childObjPtr = Tcl_NewStringObj(childCmd, -1);
Tcl_IncrRefCount(childObjPtr);
targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
Tcl_IncrRefCount(targetObjPtr);
result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
targetObjPtr, argc, objv);
for (i = 0; i < argc; i++) {
Tcl_DecrRefCount(objv[i]);
}
TclStackFree(childInterp, objv);
Tcl_DecrRefCount(targetObjPtr);
Tcl_DecrRefCount(childObjPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1225 1226 1227 1228 1229 1230 1231 | * Creates a new alias. * *---------------------------------------------------------------------- */ int Tcl_CreateAliasObj( | | | | | | | | | 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 |
* Creates a new alias.
*
*----------------------------------------------------------------------
*/
int
Tcl_CreateAliasObj(
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 *childObjPtr, *targetObjPtr;
int result;
childObjPtr = Tcl_NewStringObj(childCmd, -1);
Tcl_IncrRefCount(childObjPtr);
targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
Tcl_IncrRefCount(targetObjPtr);
result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
targetObjPtr, objc, objv);
Tcl_DecrRefCount(childObjPtr);
Tcl_DecrRefCount(targetObjPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1281 1282 1283 1284 1285 1286 1287 |
{
InterpInfo *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
int i, objc;
Tcl_Obj **objv;
| | | 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 |
{
InterpInfo *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
int i, objc;
Tcl_Obj **objv;
hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" not found", aliasName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
|
| ︙ | ︙ | |||
1343 1344 1345 1346 1347 1348 1349 |
{
InterpInfo *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
int objc;
Tcl_Obj **objv;
| | | 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 |
{
InterpInfo *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
int objc;
Tcl_Obj **objv;
hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" not found", aliasName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
|
| ︙ | ︙ | |||
1431 1432 1433 1434 1435 1436 1437 |
/*
* If the target of the next alias in the chain is the same as the
* source alias, we have a loop.
*/
if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) {
/*
| | | 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 |
/*
* If the target of the next alias in the chain is the same as the
* source alias, we have a loop.
*/
if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) {
/*
* The child interpreter can be deleted while creating the alias.
* [Bug #641195]
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot define or rename alias \"%s\": interpreter deleted",
Tcl_GetCommandName(cmdInterp, cmd)));
return TCL_ERROR;
|
| ︙ | ︙ | |||
1484 1485 1486 1487 1488 1489 1490 | * Helper function to do the work to actually create an alias. * * Results: * A standard Tcl result. * * Side effects: * An alias command is created and entered into the alias table for the | | | | | | | | | | | | | | | | | | | | | 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 |
* Helper function to do the work to actually create an alias.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* An alias command is created and entered into the alias table for the
* child interpreter.
*
*----------------------------------------------------------------------
*/
static int
AliasCreate(
Tcl_Interp *interp, /* Interp for error reporting. */
Tcl_Interp *childInterp, /* Interp where alias cmd will live or from
* which alias will be deleted. */
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. */
int objc, /* Additional arguments to store */
Tcl_Obj *const objv[]) /* with alias. */
{
Alias *aliasPtr;
Tcl_HashEntry *hPtr;
Target *targetPtr;
Child *childPtr;
Parent *parentPtr;
Tcl_Obj **prefv;
int isNew, i;
aliasPtr = (Alias *)Tcl_Alloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *));
aliasPtr->token = namePtr;
Tcl_IncrRefCount(aliasPtr->token);
aliasPtr->targetInterp = parentInterp;
aliasPtr->objc = objc + 1;
prefv = &aliasPtr->objPtr;
*prefv = targetNamePtr;
Tcl_IncrRefCount(targetNamePtr);
for (i = 0; i < objc; i++) {
*(++prefv) = objv[i];
Tcl_IncrRefCount(objv[i]);
}
Tcl_Preserve(childInterp);
Tcl_Preserve(parentInterp);
if (childInterp == parentInterp) {
aliasPtr->childCmd = Tcl_NRCreateCommand(childInterp,
TclGetString(namePtr), TclLocalAliasObjCmd, AliasNRCmd,
aliasPtr, AliasObjCmdDeleteProc);
} else {
aliasPtr->childCmd = Tcl_CreateObjCommand(childInterp,
TclGetString(namePtr), TclAliasObjCmd, aliasPtr,
AliasObjCmdDeleteProc);
}
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
* careful to wipe out its client data first, so the command doesn't
* try to delete itself.
*/
Command *cmdPtr;
Tcl_DecrRefCount(aliasPtr->token);
Tcl_DecrRefCount(targetNamePtr);
for (i = 0; i < objc; i++) {
Tcl_DecrRefCount(objv[i]);
}
cmdPtr = (Command *) aliasPtr->childCmd;
cmdPtr->clientData = NULL;
cmdPtr->deleteProc = NULL;
cmdPtr->deleteData = NULL;
Tcl_DeleteCommandFromToken(childInterp, aliasPtr->childCmd);
Tcl_Free(aliasPtr);
/*
* The result was already set by TclPreventAliasLoop.
*/
Tcl_Release(childInterp);
Tcl_Release(parentInterp);
return TCL_ERROR;
}
/*
* Make an entry in the alias table. If it already exists, retry.
*/
childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child;
while (1) {
Tcl_Obj *newToken;
const char *string;
string = TclGetString(aliasPtr->token);
hPtr = Tcl_CreateHashEntry(&childPtr->aliasTable, string, &isNew);
if (isNew != 0) {
break;
}
/*
* The alias name cannot be used as unique token, it is already taken.
* We can produce a unique token by prepending "::" repeatedly. This
|
| ︙ | ︙ | |||
1618 1619 1620 1621 1622 1623 1624 |
*
* interp alias {} foo {} bar # Create an alias "foo"
* rename foo zop # Now rename the alias
* interp alias {} foo {} zop # Now recreate "foo"...
*/
targetPtr = (Target *)Tcl_Alloc(sizeof(Target));
| | | | | | | | | | | | | | | | | | | 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 |
*
* interp alias {} foo {} bar # Create an alias "foo"
* rename foo zop # Now rename the alias
* interp alias {} foo {} zop # Now recreate "foo"...
*/
targetPtr = (Target *)Tcl_Alloc(sizeof(Target));
targetPtr->childCmd = aliasPtr->childCmd;
targetPtr->childInterp = childInterp;
parentPtr = &((InterpInfo*) ((Interp*) parentInterp)->interpInfo)->parent;
targetPtr->nextPtr = parentPtr->targetsPtr;
targetPtr->prevPtr = NULL;
if (parentPtr->targetsPtr != NULL) {
parentPtr->targetsPtr->prevPtr = targetPtr;
}
parentPtr->targetsPtr = targetPtr;
aliasPtr->targetPtr = targetPtr;
Tcl_SetObjResult(interp, aliasPtr->token);
Tcl_Release(childInterp);
Tcl_Release(parentInterp);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* AliasDelete --
*
* Deletes the given alias from the child interpreter given.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Deletes the alias from the child interpreter.
*
*----------------------------------------------------------------------
*/
static int
AliasDelete(
Tcl_Interp *interp, /* Interpreter for result & errors. */
Tcl_Interp *childInterp, /* Interpreter containing alias. */
Tcl_Obj *namePtr) /* Name of alias to delete. */
{
Child *childPtr;
Alias *aliasPtr;
Tcl_HashEntry *hPtr;
/*
* 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.
*/
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)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS",
TclGetString(namePtr), NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
Tcl_DeleteCommandFromToken(childInterp, aliasPtr->childCmd);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* AliasDescribe --
|
| ︙ | ︙ | |||
1704 1705 1706 1707 1708 1709 1710 |
*
*----------------------------------------------------------------------
*/
static int
AliasDescribe(
Tcl_Interp *interp, /* Interpreter for result & errors. */
| | | | | | | | | | | | | | 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 |
*
*----------------------------------------------------------------------
*/
static int
AliasDescribe(
Tcl_Interp *interp, /* Interpreter for result & errors. */
Tcl_Interp *childInterp, /* Interpreter containing alias. */
Tcl_Obj *namePtr) /* Name of alias to describe. */
{
Child *childPtr;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
Tcl_Obj *prefixPtr;
/*
* 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.
*/
childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child;
hPtr = Tcl_FindHashEntry(&childPtr->aliasTable, TclGetString(namePtr));
if (hPtr == NULL) {
return TCL_OK;
}
aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr);
Tcl_SetObjResult(interp, prefixPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* AliasList --
*
* Computes a list of aliases defined in a child interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
AliasList(
Tcl_Interp *interp, /* Interp for data return. */
Tcl_Interp *childInterp) /* Interp whose aliases to compute. */
{
Tcl_HashEntry *entryPtr;
Tcl_HashSearch hashSearch;
Tcl_Obj *resultPtr = Tcl_NewObj();
Alias *aliasPtr;
Child *childPtr;
childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child;
entryPtr = Tcl_FirstHashEntry(&childPtr->aliasTable, &hashSearch);
for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) {
aliasPtr = (Alias *)Tcl_GetHashValue(entryPtr);
Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token);
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclAliasObjCmd, TclLocalAliasObjCmd --
*
* 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
* parent interpreter as designated by the Alias record associated with
* this command.
*
* TclLocalAliasObjCmd is a stripped down version used when the source
* and target interpreters of the alias are the same. That lets a number
* of safety precautions be avoided: the state is much more precisely
* known.
*
|
| ︙ | ︙ | |||
2005 2006 2007 2008 2009 2010 2011 | } /* *---------------------------------------------------------------------- * * AliasObjCmdDeleteProc -- * | | | 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 | } /* *---------------------------------------------------------------------- * * AliasObjCmdDeleteProc -- * * Is invoked when an alias command is deleted in a child. Cleans up all * storage associated with this alias. * * Results: * None. * * Side effects: * Deletes the alias record and its entry in the alias table for the |
| ︙ | ︙ | |||
2035 2036 2037 2038 2039 2040 2041 |
objv = &aliasPtr->objPtr;
for (i = 0; i < aliasPtr->objc; i++) {
Tcl_DecrRefCount(objv[i]);
}
Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);
/*
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 |
objv = &aliasPtr->objPtr;
for (i = 0; i < aliasPtr->objc; i++) {
Tcl_DecrRefCount(objv[i]);
}
Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);
/*
* 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 {
Parent *parentPtr = &((InterpInfo *) ((Interp *)
aliasPtr->targetInterp)->interpInfo)->parent;
parentPtr->targetsPtr = targetPtr->nextPtr;
}
if (targetPtr->nextPtr != NULL) {
targetPtr->nextPtr->prevPtr = targetPtr->prevPtr;
}
Tcl_Free(targetPtr);
Tcl_Free(aliasPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateChild --
*
* 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 childPath
* argument contains only one component. Optionally makes the child
* interpreter safe.
*
* Results:
* Returns the interpreter structure created, or NULL if an error
* occurred.
*
* Side effects:
* Creates a new interpreter and a new interpreter object command in the
* interpreter indicated by the childPath argument.
*
*----------------------------------------------------------------------
*/
Tcl_Interp *
Tcl_CreateChild(
Tcl_Interp *interp, /* Interpreter to start search at. */
const char *childPath, /* Name of child to create. */
int isSafe) /* Should new child be "safe" ? */
{
Tcl_Obj *pathPtr;
Tcl_Interp *childInterp;
pathPtr = Tcl_NewStringObj(childPath, -1);
childInterp = ChildCreate(interp, pathPtr, isSafe);
Tcl_DecrRefCount(pathPtr);
return childInterp;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetChild --
*
* Finds a child interpreter by its path name.
*
* Results:
* Returns a Tcl_Interp * for the named interpreter or NULL if not found.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Interp *
Tcl_GetChild(
Tcl_Interp *interp, /* Interpreter to start search from. */
const char *childPath) /* Path of child to find. */
{
Tcl_Obj *pathPtr;
Tcl_Interp *childInterp;
pathPtr = Tcl_NewStringObj(childPath, -1);
childInterp = GetInterp(interp, pathPtr);
Tcl_DecrRefCount(pathPtr);
return childInterp;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetParent --
*
* Finds the parent interpreter of a child interpreter.
*
* Results:
* Returns a Tcl_Interp * for the parent interpreter or NULL if none.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Interp *
Tcl_GetParent(
Tcl_Interp *interp) /* Get the parent of this interpreter. */
{
Child *childPtr; /* Child record of this interpreter. */
if (interp == NULL) {
return NULL;
}
childPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->child;
return childPtr->parentInterp;
}
/*
*----------------------------------------------------------------------
*
* TclSetChildCancelFlags --
*
* This function marks all child interpreters belonging to a given
* interpreter as being canceled or not canceled, depending on the
* provided flags.
*
* Results:
* None.
*
* Side effects:
|
| ︙ | ︙ | |||
2182 2183 2184 2185 2186 2187 2188 |
int flags, /* Collection of OR-ed bits that control
* the cancellation of the script. Only
* TCL_CANCEL_UNWIND is currently
* supported. */
int force) /* Non-zero to ignore numLevels for the purpose
* of resetting the cancellation flags. */
{
| | | | | | | | | | 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 |
int flags, /* Collection of OR-ed bits that control
* the cancellation of the script. Only
* TCL_CANCEL_UNWIND is currently
* supported. */
int force) /* Non-zero to ignore numLevels for the purpose
* of resetting the cancellation flags. */
{
Parent *parentPtr; /* Parent record of given interpreter. */
Tcl_HashEntry *hPtr; /* Search element. */
Tcl_HashSearch hashSearch; /* Search variable. */
Child *childPtr; /* Child record of interpreter. */
Interp *iPtr;
if (interp == NULL) {
return;
}
flags &= (CANCELED | TCL_CANCEL_UNWIND);
parentPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->parent;
hPtr = Tcl_FirstHashEntry(&parentPtr->childTable, &hashSearch);
for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
childPtr = (Child *)Tcl_GetHashValue(hPtr);
iPtr = (Interp *) childPtr->childInterp;
if (iPtr == NULL) {
continue;
}
if (flags == 0) {
TclResetCancellation((Tcl_Interp *) iPtr, force);
} else {
TclSetCancelFlags(iPtr, flags);
}
/*
* Now, recursively handle this for the children of this child
* interpreter.
*/
TclSetChildCancelFlags((Tcl_Interp *) iPtr, flags, force);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetInterpPath --
*
* 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 children (including recursively).
*
* Results:
* TCL_OK if the target interpreter is the same as, or a descendant of,
* the asking interpreter; TCL_ERROR else. This way one can distinguish
* between the case where the asking and target interps are the same (an
* empty list is the result, and TCL_OK is returned) and when the target
* is not a descendant of the asking interpreter (in which case the Tcl
|
| ︙ | ︙ | |||
2259 2260 2261 2262 2263 2264 2265 |
Tcl_SetObjResult(interp, Tcl_NewObj());
return TCL_OK;
}
if (targetInterp == NULL) {
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 |
Tcl_SetObjResult(interp, Tcl_NewObj());
return TCL_OK;
}
if (targetInterp == NULL) {
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
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->parent.childTable,
iiPtr->child.childEntryPtr), -1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* GetInterp --
*
* Helper function to find a child interpreter given a pathname.
*
* Results:
* Returns the child interpreter known by that name in the calling
* interpreter, or NULL if no interpreter known by that name exists.
*
* Side effects:
* Assigns to the pointer variable passed in, if not NULL.
*
*----------------------------------------------------------------------
*/
static Tcl_Interp *
GetInterp(
Tcl_Interp *interp, /* Interp. to start search from. */
Tcl_Obj *pathPtr) /* List object containing name of interp. to
* be found. */
{
Tcl_HashEntry *hPtr; /* Search element. */
Child *childPtr; /* Interim child record. */
Tcl_Obj **objv;
int objc, i;
Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */
InterpInfo *parentInfoPtr;
if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
return NULL;
}
searchInterp = interp;
for (i = 0; i < objc; i++) {
parentInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo;
hPtr = Tcl_FindHashEntry(&parentInfoPtr->parent.childTable,
TclGetString(objv[i]));
if (hPtr == NULL) {
searchInterp = NULL;
break;
}
childPtr = (Child *)Tcl_GetHashValue(hPtr);
searchInterp = childPtr->childInterp;
if (searchInterp == NULL) {
break;
}
}
if (searchInterp == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not find interpreter \"%s\"", TclGetString(pathPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INTERP",
TclGetString(pathPtr), NULL);
}
return searchInterp;
}
/*
*----------------------------------------------------------------------
*
* ChildBgerror --
*
* Helper function to set/query the background error handling command
* prefix of an interp
*
* Results:
* A standard Tcl result.
*
* Side effects:
* When (objc == 1), childInterp will be set to a new background handler
* of objv[0].
*
*----------------------------------------------------------------------
*/
static int
ChildBgerror(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */
int objc, /* Set or Query. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
if (objc) {
int length;
if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length)
|| (length < 1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cmdPrefix must be list of length >= 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BGERRORFORMAT", NULL);
return TCL_ERROR;
}
TclSetBgErrorHandler(childInterp, objv[0]);
}
Tcl_SetObjResult(interp, TclGetBgErrorHandler(childInterp));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ChildCreate --
*
* 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:
* Returns the new Tcl_Interp * if successful or NULL if not. If failed,
* the result of the invoking interpreter contains an error message.
*
* Side effects:
* Creates a new child interpreter and a new object command.
*
*----------------------------------------------------------------------
*/
static Tcl_Interp *
ChildCreate(
Tcl_Interp *interp, /* Interp. to start search from. */
Tcl_Obj *pathPtr, /* Path (name) of child to create. */
int safe) /* Should we make it "safe"? */
{
Tcl_Interp *parentInterp, *childInterp;
Child *childPtr;
InterpInfo *parentInfoPtr;
Tcl_HashEntry *hPtr;
const char *path;
int isNew, objc;
Tcl_Obj **objv;
if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
return NULL;
}
if (objc < 2) {
parentInterp = interp;
path = TclGetString(pathPtr);
} else {
Tcl_Obj *objPtr;
objPtr = Tcl_NewListObj(objc - 1, objv);
parentInterp = GetInterp(interp, objPtr);
Tcl_DecrRefCount(objPtr);
if (parentInterp == NULL) {
return NULL;
}
path = TclGetString(objv[objc - 1]);
}
if (safe == 0) {
safe = Tcl_IsSafe(parentInterp);
}
parentInfoPtr = (InterpInfo *) ((Interp *) parentInterp)->interpInfo;
hPtr = Tcl_CreateHashEntry(&parentInfoPtr->parent.childTable, path,
&isNew);
if (isNew == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"interpreter named \"%s\" already exists, cannot create",
path));
return NULL;
}
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 *) childInterp)->maxNestingDepth =
((Interp *) parentInterp)->maxNestingDepth;
if (safe) {
if (Tcl_MakeSafe(childInterp) == TCL_ERROR) {
goto error;
}
} else {
if (Tcl_Init(childInterp) == TCL_ERROR) {
goto error;
}
/*
* This will create the "memory" command in child interpreters if we
* compiled with TCL_MEM_DEBUG, otherwise it does nothing.
*/
Tcl_InitMemory(childInterp);
}
/*
* Inherit the TIP#143 limits.
*/
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) parent.
*/
if (safe) {
Tcl_Obj *clockObj;
int status;
TclNewLiteralStringObj(clockObj, "clock");
Tcl_IncrRefCount(clockObj);
status = AliasCreate(interp, childInterp, parentInterp, clockObj,
clockObj, 0, NULL);
Tcl_DecrRefCount(clockObj);
if (status != TCL_OK) {
goto error2;
}
}
return childInterp;
error:
Tcl_TransferResult(childInterp, TCL_ERROR, interp);
error2:
Tcl_DeleteInterp(childInterp);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* TclChildObjCmd --
*
* Command to manipulate an interpreter, e.g. to send commands to it to
* be evaluated. One such command exists for each child interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See user documentation for details.
*
*----------------------------------------------------------------------
*/
int
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, NRChildCmd, clientData, objc, objv);
}
static int
NRChildCmd(
ClientData clientData, /* Child interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *childInterp = (Tcl_Interp *)clientData;
int index;
static const char *const options[] = {
"alias", "aliases", "bgerror", "debug",
"eval", "expose", "hide", "hidden",
"issafe", "invokehidden", "limit", "marktrusted",
"recursionlimit", NULL
};
enum options {
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 (childInterp == NULL) {
Tcl_Panic("TclChildObjCmd: interpreter has been deleted");
}
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) {
return TCL_ERROR;
}
switch ((enum options) index) {
case OPT_ALIAS:
if (objc > 2) {
if (objc == 3) {
return AliasDescribe(interp, childInterp, objv[2]);
}
if (TclGetString(objv[3])[0] == '\0') {
if (objc == 4) {
return AliasDelete(interp, childInterp, objv[2]);
}
} else {
return AliasCreate(interp, childInterp, interp, objv[2],
objv[3], objc - 4, objv + 4);
}
}
Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?arg ...?");
return TCL_ERROR;
case OPT_ALIASES:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
return AliasList(interp, childInterp);
case OPT_BGERROR:
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?");
return TCL_ERROR;
}
return ChildBgerror(interp, childInterp, objc - 2, objv + 2);
case OPT_DEBUG:
/*
* TIP #378
* Currently only -frame supported, otherwise ?-option ?value? ...?
*/
if (objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "?-frame ?bool??");
return TCL_ERROR;
}
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 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 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 ChildHide(interp, childInterp, objc - 2, objv + 2);
case OPT_HIDDEN:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
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(childInterp)));
return TCL_OK;
case OPT_INVOKEHIDDEN: {
int i;
const char *namespaceName;
static const char *const hiddenOptions[] = {
"-global", "-namespace", "--", NULL
};
|
| ︙ | ︙ | |||
2672 2673 2674 2675 2676 2677 2678 |
}
}
if (objc - i < 1) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-namespace ns? ?-global? ?--? cmd ?arg ..?");
return TCL_ERROR;
}
| | | 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 |
}
}
if (objc - i < 1) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-namespace ns? ?-global? ?--? cmd ?arg ..?");
return TCL_ERROR;
}
return ChildInvokeHidden(interp, childInterp, namespaceName,
objc - i, objv + i);
}
case OPT_LIMIT: {
static const char *const limitTypes[] = {
"commands", "time", NULL
};
enum LimitTypes {
|
| ︙ | ︙ | |||
2694 2695 2696 2697 2698 2699 2700 |
}
if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0,
&limitType) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum LimitTypes) limitType) {
case LIMIT_TYPE_COMMANDS:
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 |
}
if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0,
&limitType) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum LimitTypes) limitType) {
case LIMIT_TYPE_COMMANDS:
return ChildCommandLimitCmd(interp, childInterp, 3, objc,objv);
case LIMIT_TYPE_TIME:
return ChildTimeLimitCmd(interp, childInterp, 3, objc, objv);
}
}
break;
case OPT_MARKTRUSTED:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
return ChildMarkTrusted(interp, childInterp);
case OPT_RECLIMIT:
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?");
return TCL_ERROR;
}
return ChildRecursionLimit(interp, childInterp, objc - 2, objv + 2);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* ChildObjCmdDeleteProc --
*
* 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 child interpreter and destroys
* the child interpreter.
*
*----------------------------------------------------------------------
*/
static void
ChildObjCmdDeleteProc(
ClientData clientData) /* The ChildRecord for the command. */
{
Child *childPtr; /* Interim storage for Child record. */
Tcl_Interp *childInterp = (Tcl_Interp *)clientData;
/* And for a child interp. */
childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child;
/*
* Unlink the child from its parent interpreter.
*/
Tcl_DeleteHashEntry(childPtr->childEntryPtr);
/*
* 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
* ChildRecordDeleteProc().
*/
childPtr->interpCmd = NULL;
if (childPtr->childInterp != NULL) {
Tcl_DeleteInterp(childPtr->childInterp);
}
}
/*
*----------------------------------------------------------------------
*
* ChildDebugCmd -- TIP #378
*
* 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 child.
*
*----------------------------------------------------------------------
*/
static int
ChildDebugCmd(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* The child interpreter in which command
* will be evaluated. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const debugTypes[] = {
"-frame", NULL
};
enum DebugTypes {
DEBUG_TYPE_FRAME
};
int debugType;
Interp *iPtr;
Tcl_Obj *resultPtr;
iPtr = (Interp *) childInterp;
if (objc == 0) {
resultPtr = Tcl_NewObj();
Tcl_ListObjAppendElement(NULL, resultPtr,
Tcl_NewStringObj("-frame", -1));
Tcl_ListObjAppendElement(NULL, resultPtr,
Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME));
Tcl_SetObjResult(interp, resultPtr);
|
| ︙ | ︙ | |||
2839 2840 2841 2842 2843 2844 2845 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| | | | | | | | | | | | | | | | | | | | | | | | | | | 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ChildEval --
*
* Helper function to evaluate a command in a child interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Whatever the command does.
*
*----------------------------------------------------------------------
*/
static int
ChildEval(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* The child interpreter in which command
* will be evaluated. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result;
/*
* 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(childInterp, 0, 0);
Tcl_Preserve(childInterp);
Tcl_AllowExceptions(childInterp);
if (objc == 1) {
/*
* TIP #280: Make actual argument location available to eval'd script.
*/
Interp *iPtr = (Interp *) interp;
CmdFrame *invoker = iPtr->cmdFramePtr;
int word = 0;
TclArgumentGet(interp, objv[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(childInterp, objPtr, 0);
Tcl_DecrRefCount(objPtr);
}
Tcl_TransferResult(childInterp, result, interp);
Tcl_Release(childInterp);
return result;
}
/*
*----------------------------------------------------------------------
*
* ChildExpose --
*
* Helper function to expose a command in a child interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* After this call scripts in the child will be able to invoke the newly
* exposed command.
*
*----------------------------------------------------------------------
*/
static int
ChildExpose(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which command will be exposed. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
const char *name;
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"permission denied: safe interpreter cannot expose commands",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
NULL);
return TCL_ERROR;
}
name = TclGetString(objv[(objc == 1) ? 0 : 1]);
if (Tcl_ExposeCommand(childInterp, TclGetString(objv[0]),
name) != TCL_OK) {
Tcl_TransferResult(childInterp, TCL_ERROR, interp);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ChildRecursionLimit --
*
* Helper function to set/query the Recursion limit of an interp
*
* Results:
* A standard Tcl result.
*
* Side effects:
* When (objc == 1), childInterp will be set to a new recursion limit of
* objv[0].
*
*----------------------------------------------------------------------
*/
static int
ChildRecursionLimit(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */
int objc, /* Set or Query. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
Interp *iPtr;
int limit;
if (objc) {
|
| ︙ | ︙ | |||
2988 2989 2990 2991 2992 2993 2994 |
if (limit <= 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"recursion limit must be > 0", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT",
NULL);
return TCL_ERROR;
}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 |
if (limit <= 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"recursion limit must be > 0", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT",
NULL);
return TCL_ERROR;
}
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);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[0]);
return TCL_OK;
} else {
limit = Tcl_SetRecursionLimit(childInterp, 0);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limit));
return TCL_OK;
}
}
/*
*----------------------------------------------------------------------
*
* ChildHide --
*
* Helper function to hide a command in a child interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* After this call scripts in the child will no longer be able to invoke
* the named command.
*
*----------------------------------------------------------------------
*/
static int
ChildHide(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which command will be exposed. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
const char *name;
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"permission denied: safe interpreter cannot hide commands",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
NULL);
return TCL_ERROR;
}
name = TclGetString(objv[(objc == 1) ? 0 : 1]);
if (Tcl_HideCommand(childInterp, TclGetString(objv[0]), name) != TCL_OK) {
Tcl_TransferResult(childInterp, TCL_ERROR, interp);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ChildHidden --
*
* Helper function to compute list of hidden commands in a child
* interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ChildHidden(
Tcl_Interp *interp, /* Interp for data return. */
Tcl_Interp *childInterp) /* Interp whose hidden commands to query. */
{
Tcl_Obj *listObjPtr = Tcl_NewObj(); /* Local object pointer. */
Tcl_HashTable *hTblPtr; /* For local searches. */
Tcl_HashEntry *hPtr; /* For local searches. */
Tcl_HashSearch hSearch; /* For local searches. */
hTblPtr = ((Interp *) childInterp)->hiddenCmdTablePtr;
if (hTblPtr != NULL) {
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
Tcl_ListObjAppendElement(NULL, listObjPtr,
Tcl_NewStringObj((const char *)Tcl_GetHashKey(hTblPtr, hPtr), -1));
}
}
Tcl_SetObjResult(interp, listObjPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ChildInvokeHidden --
*
* Helper function to invoke a hidden command in a child interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Whatever the hidden command does.
*
*----------------------------------------------------------------------
*/
static int
ChildInvokeHidden(
Tcl_Interp *interp, /* Interp for error return. */
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. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result;
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"not allowed to invoke hidden commands from safe interpreter",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
NULL);
return TCL_ERROR;
}
Tcl_Preserve(childInterp);
Tcl_AllowExceptions(childInterp);
if (namespaceName == NULL) {
NRE_callback *rootPtr = TOP_CB(childInterp);
Tcl_NRAddCallback(interp, NRPostInvokeHidden, childInterp,
rootPtr, NULL, NULL);
return TclNRInvoke(NULL, childInterp, objc, objv);
} else {
Namespace *nsPtr, *dummy1, *dummy2;
const char *tail;
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(childInterp, objc, objv,
(Tcl_Namespace *) nsPtr, TCL_INVOKE_HIDDEN);
}
}
Tcl_TransferResult(childInterp, result, interp);
Tcl_Release(childInterp);
return result;
}
static int
NRPostInvokeHidden(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Interp *childInterp = (Tcl_Interp *)data[0];
NRE_callback *rootPtr = (NRE_callback *)data[1];
if (interp != childInterp) {
result = TclNRRunCallbacks(childInterp, result, rootPtr);
Tcl_TransferResult(childInterp, result, interp);
}
Tcl_Release(childInterp);
return result;
}
/*
*----------------------------------------------------------------------
*
* ChildMarkTrusted --
*
* 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 child from performing certain operations.
*
*----------------------------------------------------------------------
*/
static int
ChildMarkTrusted(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp) /* The child interpreter which will be marked
* trusted. */
{
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"permission denied: safe interpreter cannot mark trusted",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
NULL);
return TCL_ERROR;
}
((Interp *) childInterp)->flags &= ~SAFE_INTERP;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_IsSafe --
|
| ︙ | ︙ | |||
3257 3258 3259 3260 3261 3262 3263 |
int
Tcl_MakeSafe(
Tcl_Interp *interp) /* Interpreter to be made safe. */
{
Tcl_Channel chan; /* Channel to remove from safe interpreter. */
Interp *iPtr = (Interp *) interp;
| | | | | | | 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 |
int
Tcl_MakeSafe(
Tcl_Interp *interp) /* Interpreter to be made safe. */
{
Tcl_Channel chan; /* Channel to remove from safe interpreter. */
Interp *iPtr = (Interp *) interp;
Tcl_Interp *parent = ((InterpInfo*) iPtr->interpInfo)->child.parentInterp;
TclHideUnsafeCommands(interp);
if (parent != NULL) {
/*
* 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]
*/
(void) Tcl_EvalEx(interp,
"namespace eval ::tcl {namespace eval mathfunc {}}", -1, 0);
}
iPtr->flags |= SAFE_INTERP;
/*
* Unsetting variables : (which should not have been set in the first
* place, but...)
*/
/*
* No env array in a safe interpreter.
*/
Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY);
/*
* Remove unsafe parts of tcl_platform
*/
|
| ︙ | ︙ | |||
4182 4183 4184 4185 4186 4187 4188 | /* *---------------------------------------------------------------------- * * DeleteScriptLimitCallback -- * * Callback for when a script limit (a limit callback implemented as a | | | 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 | /* *---------------------------------------------------------------------- * * DeleteScriptLimitCallback -- * * Callback for when a script limit (a limit callback implemented as a * Tcl script in a parent interpreter, as set up from Tcl) is deleted. * * Results: * None. * * Side effects: * The reference to the script callback from the controlling interpreter * is removed. |
| ︙ | ︙ | |||
4395 4396 4397 4398 4399 4400 4401 |
Tcl_InitHashTable(&iPtr->limit.callbacks,
sizeof(ScriptLimitCallbackKey)/sizeof(int));
}
/*
*----------------------------------------------------------------------
*
| | | | | | | | | | | | | | | | | | | | | | | | | 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 |
Tcl_InitHashTable(&iPtr->limit.callbacks,
sizeof(ScriptLimitCallbackKey)/sizeof(int));
}
/*
*----------------------------------------------------------------------
*
* InheritLimitsFromParent --
*
* Derive the interpreter limit configuration for a child interpreter
* from the limit config for the parent.
*
* Results:
* None.
*
* Side effects:
* 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
InheritLimitsFromParent(
Tcl_Interp *childInterp,
Tcl_Interp *parentInterp)
{
Interp *childPtr = (Interp *) childInterp;
Interp *parentPtr = (Interp *) parentInterp;
if (parentPtr->limit.active & TCL_LIMIT_COMMANDS) {
childPtr->limit.active |= TCL_LIMIT_COMMANDS;
childPtr->limit.cmdCount = 0;
childPtr->limit.cmdGranularity = parentPtr->limit.cmdGranularity;
}
if (parentPtr->limit.active & TCL_LIMIT_TIME) {
childPtr->limit.active |= TCL_LIMIT_TIME;
memcpy(&childPtr->limit.time, &parentPtr->limit.time,
sizeof(Tcl_Time));
childPtr->limit.timeGranularity = parentPtr->limit.timeGranularity;
}
}
/*
*----------------------------------------------------------------------
*
* ChildCommandLimitCmd --
*
* Implementation of the [interp limit $i commands] and [$i limit
* commands] subcommands. See the interp manual page for a full
* description.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Depends on the arguments.
*
*----------------------------------------------------------------------
*/
static int
ChildCommandLimitCmd(
Tcl_Interp *interp, /* Current interpreter. */
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. */
{
static const char *const options[] = {
"-command", "-granularity", "-value", NULL
};
|
| ︙ | ︙ | |||
4478 4479 4480 4481 4482 4483 4484 |
/*
* First, ensure that we are not reading or writing the calling
* interpreter's limits; it may only manipulate its children. Note that
* the low level API enforces this with Tcl_Panic, which we want to
* avoid. [Bug 3398794]
*/
| | | | | | | | | | | 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 |
/*
* First, ensure that we are not reading or writing the calling
* interpreter's limits; it may only manipulate its children. Note that
* the low level API enforces this with Tcl_Panic, which we want to
* avoid. [Bug 3398794]
*/
if (interp == childInterp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"limits on current interpreter inaccessible", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL);
return TCL_ERROR;
}
if (objc == consumedObjc) {
Tcl_Obj *dictPtr;
TclNewObj(dictPtr);
key.interp = childInterp;
key.type = TCL_LIMIT_COMMANDS;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
if (hPtr != NULL) {
limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1),
limitCBPtr->scriptObj);
} else {
goto putEmptyCommandInDict;
}
} else {
Tcl_Obj *empty;
putEmptyCommandInDict:
TclNewObj(empty);
Tcl_DictObjPut(NULL, dictPtr,
Tcl_NewStringObj(options[0], -1), empty);
}
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
Tcl_NewWideIntObj(Tcl_LimitGetGranularity(childInterp,
TCL_LIMIT_COMMANDS)));
if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) {
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1),
Tcl_NewWideIntObj(Tcl_LimitGetCommands(childInterp)));
} else {
Tcl_Obj *empty;
TclNewObj(empty);
Tcl_DictObjPut(NULL, dictPtr,
Tcl_NewStringObj(options[2], -1), empty);
}
Tcl_SetObjResult(interp, dictPtr);
return TCL_OK;
} else if (objc == consumedObjc+1) {
if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option",
0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum Options) index) {
case OPT_CMD:
key.interp = childInterp;
key.type = TCL_LIMIT_COMMANDS;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
if (hPtr != NULL) {
limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
Tcl_SetObjResult(interp, limitCBPtr->scriptObj);
}
}
break;
case OPT_GRAN:
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_COMMANDS)));
break;
case OPT_VAL:
if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) {
Tcl_SetObjResult(interp,
Tcl_NewWideIntObj(Tcl_LimitGetCommands(childInterp)));
}
break;
}
return TCL_OK;
} else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
4605 4606 4607 4608 4609 4610 4611 |
"BADVALUE", NULL);
return TCL_ERROR;
}
break;
}
}
if (scriptObj != NULL) {
| | | | | | | | | | 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 |
"BADVALUE", NULL);
return TCL_ERROR;
}
break;
}
}
if (scriptObj != NULL) {
SetScriptLimitCallback(interp, TCL_LIMIT_COMMANDS, childInterp,
(scriptLen > 0 ? scriptObj : NULL));
}
if (granObj != NULL) {
Tcl_LimitSetGranularity(childInterp, TCL_LIMIT_COMMANDS, gran);
}
if (limitObj != NULL) {
if (limitLen > 0) {
Tcl_LimitSetCommands(childInterp, limit);
Tcl_LimitTypeSet(childInterp, TCL_LIMIT_COMMANDS);
} else {
Tcl_LimitTypeReset(childInterp, TCL_LIMIT_COMMANDS);
}
}
return TCL_OK;
}
}
/*
*----------------------------------------------------------------------
*
* ChildTimeLimitCmd --
*
* Implementation of the [interp limit $i time] and [$i limit time]
* subcommands. See the interp manual page for a full description.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Depends on the arguments.
*
*----------------------------------------------------------------------
*/
static int
ChildTimeLimitCmd(
Tcl_Interp *interp, /* Current interpreter. */
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. */
{
static const char *const options[] = {
"-command", "-granularity", "-milliseconds", "-seconds", NULL
};
|
| ︙ | ︙ | |||
4667 4668 4669 4670 4671 4672 4673 |
/*
* First, ensure that we are not reading or writing the calling
* interpreter's limits; it may only manipulate its children. Note that
* the low level API enforces this with Tcl_Panic, which we want to
* avoid. [Bug 3398794]
*/
| | | | | | | 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 |
/*
* First, ensure that we are not reading or writing the calling
* interpreter's limits; it may only manipulate its children. Note that
* the low level API enforces this with Tcl_Panic, which we want to
* avoid. [Bug 3398794]
*/
if (interp == childInterp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"limits on current interpreter inaccessible", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL);
return TCL_ERROR;
}
if (objc == consumedObjc) {
Tcl_Obj *dictPtr;
TclNewObj(dictPtr);
key.interp = childInterp;
key.type = TCL_LIMIT_TIME;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
if (hPtr != NULL) {
limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1),
limitCBPtr->scriptObj);
} else {
goto putEmptyCommandInDict;
}
} else {
Tcl_Obj *empty;
putEmptyCommandInDict:
TclNewObj(empty);
Tcl_DictObjPut(NULL, dictPtr,
Tcl_NewStringObj(options[0], -1), empty);
}
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
Tcl_NewWideIntObj(Tcl_LimitGetGranularity(childInterp,
TCL_LIMIT_TIME)));
if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) {
Tcl_Time 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),
Tcl_NewWideIntObj(limitMoment.sec));
} else {
Tcl_Obj *empty;
|
| ︙ | ︙ | |||
4726 4727 4728 4729 4730 4731 4732 |
} else if (objc == consumedObjc+1) {
if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option",
0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum Options) index) {
case OPT_CMD:
| | | | | | | | | 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 |
} else if (objc == consumedObjc+1) {
if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option",
0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum Options) index) {
case OPT_CMD:
key.interp = childInterp;
key.type = TCL_LIMIT_TIME;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
if (hPtr != NULL) {
limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
Tcl_SetObjResult(interp, limitCBPtr->scriptObj);
}
}
break;
case OPT_GRAN:
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_TIME)));
break;
case OPT_MILLI:
if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) {
Tcl_Time limitMoment;
Tcl_LimitGetTime(childInterp, &limitMoment);
Tcl_SetObjResult(interp,
Tcl_NewWideIntObj(limitMoment.usec/1000));
}
break;
case OPT_SEC:
if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) {
Tcl_Time limitMoment;
Tcl_LimitGetTime(childInterp, &limitMoment);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limitMoment.sec));
}
break;
}
return TCL_OK;
} else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
} else {
int i;
size_t scriptLen = 0, milliLen = 0, secLen = 0;
Tcl_Obj *scriptObj = NULL, *granObj = NULL;
Tcl_Obj *milliObj = NULL, *secObj = NULL;
int gran = 0;
Tcl_Time limitMoment;
int tmp;
Tcl_LimitGetTime(childInterp, &limitMoment);
for (i=consumedObjc ; i<objc ; i+=2) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum Options) index) {
case OPT_CMD:
|
| ︙ | ︙ | |||
4868 4869 4870 4871 4872 4873 4874 | * incrementing sec in the process. This makes it much easier * for people to write scripts that do small time increments. */ limitMoment.sec += limitMoment.usec / 1000000; limitMoment.usec %= 1000000; | | | | | | | 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 |
* incrementing sec in the process. This makes it much easier
* for people to write scripts that do small time increments.
*/
limitMoment.sec += limitMoment.usec / 1000000;
limitMoment.usec %= 1000000;
Tcl_LimitSetTime(childInterp, &limitMoment);
Tcl_LimitTypeSet(childInterp, TCL_LIMIT_TIME);
} else {
Tcl_LimitTypeReset(childInterp, TCL_LIMIT_TIME);
}
}
if (scriptObj != NULL) {
SetScriptLimitCallback(interp, TCL_LIMIT_TIME, childInterp,
(scriptLen > 0 ? scriptObj : NULL));
}
if (granObj != NULL) {
Tcl_LimitSetGranularity(childInterp, TCL_LIMIT_TIME, gran);
}
return TCL_OK;
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclLoad.c.
| ︙ | ︙ | |||
111 112 113 114 115 116 117 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LoadObjCmd( | | | 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LoadObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *target;
LoadedPackage *pkgPtr, *defaultPtr;
Tcl_DString pkgName, tmp, initName, safeInitName;
|
| ︙ | ︙ | |||
192 193 194 195 196 197 198 |
/*
* Figure out which interpreter we're going to load the package into.
*/
target = interp;
if (objc == 4) {
| | | | 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 |
/*
* Figure out which interpreter we're going to load the package into.
*/
target = interp;
if (objc == 4) {
const char *childIntName = TclGetString(objv[3]);
target = Tcl_GetChild(interp, childIntName);
if (target == NULL) {
code = TCL_ERROR;
goto done;
}
}
/*
|
| ︙ | ︙ | |||
536 537 538 539 540 541 542 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_UnloadObjCmd( | | | 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_UnloadObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *target; /* Which interpreter to unload from. */
LoadedPackage *pkgPtr, *defaultPtr;
Tcl_DString pkgName, tmp;
|
| ︙ | ︙ | |||
626 627 628 629 630 631 632 |
/*
* Figure out which interpreter we're going to load the package into.
*/
target = interp;
if (objc - i == 3) {
| | | | 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 |
/*
* Figure out which interpreter we're going to load the package into.
*/
target = interp;
if (objc - i == 3) {
const char *childIntName = TclGetString(objv[i + 2]);
target = Tcl_GetChild(interp, childIntName);
if (target == NULL) {
return TCL_ERROR;
}
}
/*
* Scan through the packages that are currently loaded to see if the
|
| ︙ | ︙ | |||
1081 1082 1083 1084 1085 1086 1087 |
Tcl_NewListObj(2, pkgDesc));
}
Tcl_MutexUnlock(&packageMutex);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
| | | 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 |
Tcl_NewListObj(2, pkgDesc));
}
Tcl_MutexUnlock(&packageMutex);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
target = Tcl_GetChild(interp, targetName);
if (target == NULL) {
return TCL_ERROR;
}
ipPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL);
/*
* Return information about all of the available packages.
|
| ︙ | ︙ |
Changes to generic/tclNamesp.c.
| ︙ | ︙ | |||
1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 | } dataPtr = (ImportedCmdData *)Tcl_Alloc(sizeof(ImportedCmdData)); importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr, DeleteImportedCmd); dataPtr->realCmdPtr = cmdPtr; dataPtr->selfPtr = (Command *) importedCmd; dataPtr->selfPtr->compileProc = cmdPtr->compileProc; Tcl_DStringFree(&ds); /* * Create an ImportRef structure describing this new import command * and add it to the import ref list in the "real" command. | > > | 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 | } dataPtr = (ImportedCmdData *)Tcl_Alloc(sizeof(ImportedCmdData)); importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), 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); /* * Create an ImportRef structure describing this new import command * and add it to the import ref list in the "real" command. |
| ︙ | ︙ | |||
2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 |
if (prevPtr == NULL) { /* refPtr is first in list. */
realCmdPtr->importRefPtr = refPtr->nextPtr;
} else {
prevPtr->nextPtr = refPtr->nextPtr;
}
Tcl_Free(refPtr);
Tcl_Free(dataPtr);
return;
}
prevPtr = refPtr;
}
Tcl_Panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references");
| > | 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 |
if (prevPtr == NULL) { /* refPtr is first in list. */
realCmdPtr->importRefPtr = refPtr->nextPtr;
} else {
prevPtr->nextPtr = refPtr->nextPtr;
}
Tcl_Free(refPtr);
TclCleanupCommandMacro(realCmdPtr);
Tcl_Free(dataPtr);
return;
}
prevPtr = refPtr;
}
Tcl_Panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references");
|
| ︙ | ︙ | |||
3885 3886 3887 3888 3889 3890 3891 |
static int
NamespaceOriginCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | > > > > > > > > > > > < < < < < < < < < < < < < > | 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 |
static int
NamespaceOriginCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Command cmd, origCmd;
Tcl_Obj *resultPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
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;
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceParentCmd --
*
* Invoked to implement the "namespace parent" command that returns the
|
| ︙ | ︙ |
Changes to generic/tclOO.c.
| ︙ | ︙ | |||
129 130 131 132 133 134 135 |
static const Tcl_MethodType classConstructor = {
TCL_OO_METHOD_VERSION_CURRENT,
"oo::class constructor",
TclOO_Class_Constructor, NULL, NULL
};
/*
| | | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
static const Tcl_MethodType classConstructor = {
TCL_OO_METHOD_VERSION_CURRENT,
"oo::class constructor",
TclOO_Class_Constructor, NULL, NULL
};
/*
* Scripted parts of TclOO. First, the main script (cannot be outside this
* file).
*/
static const char *initScript =
"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
"namespace eval ::oo { variable version " TCLOO_VERSION " };"
"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
*/
if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL,
| | | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 |
*/
if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL,
(void *) &tclOOStubs);
}
/*
* ----------------------------------------------------------------------
*
* TclOOGetFoundation --
*
|
| ︙ | ︙ | |||
562 563 564 565 566 567 568 | * when the objects and classes themselves are destroyed. * * ---------------------------------------------------------------------- */ static void KillFoundation( | | | 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 |
* when the objects and classes themselves are destroyed.
*
* ----------------------------------------------------------------------
*/
static void
KillFoundation(
TCL_UNUSED(void *),
Tcl_Interp *interp) /* The interpreter containing the OO system
* foundation. */
{
Foundation *fPtr = GetFoundation(interp);
TclDecrRefCount(fPtr->unknownMethodNameObj);
TclDecrRefCount(fPtr->constructorName);
|
| ︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 |
/*
* Instruct everyone to no longer use any allocated fields of the object.
* Also delete the command that refers to the object at this point (if it
* still exists) because otherwise its pointer to the object points into
* freed memory.
*/
| | | 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 |
/*
* Instruct everyone to no longer use any allocated fields of the object.
* Also delete the command that refers to the object at this point (if it
* still exists) because otherwise its pointer to the object points into
* freed memory.
*/
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,
*/
} else {
/*
* The namespace must have been deleted directly. Delete the command
|
| ︙ | ︙ |
Changes to generic/tclOOInfo.c.
| ︙ | ︙ | |||
110 111 112 113 114 115 116 |
* Build the ensembles used to implement [info object] and [info class].
*/
TclMakeEnsemble(interp, "::oo::InfoObject", infoObjectCmds);
TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds);
/*
| | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 |
* Build the ensembles used to implement [info object] and [info class].
*/
TclMakeEnsemble(interp, "::oo::InfoObject", infoObjectCmds);
TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds);
/*
* Install into the [info] ensemble.
*/
infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
if (infoCmd) {
Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict);
Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1),
Tcl_NewStringObj("::oo::InfoObject", -1));
|
| ︙ | ︙ | |||
167 168 169 170 171 172 173 | * Implements [info object class $objName ?$className?] * * ---------------------------------------------------------------------- */ static int InfoObjectClassCmd( | | | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
* Implements [info object class $objName ?$className?]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectClassCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
if (objc != 2 && objc != 3) {
|
| ︙ | ︙ | |||
224 225 226 227 228 229 230 | * Implements [info object definition $objName $methodName] * * ---------------------------------------------------------------------- */ static int InfoObjectDefnCmd( | | | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 |
* Implements [info object definition $objName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectDefnCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Tcl_HashEntry *hPtr;
Proc *procPtr;
|
| ︙ | ︙ | |||
298 299 300 301 302 303 304 | * Implements [info object filters $objName] * * ---------------------------------------------------------------------- */ static int InfoObjectFiltersCmd( | | | 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 |
* Implements [info object filters $objName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectFiltersCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int i;
Tcl_Obj *filterObj, *resultObj;
Object *oPtr;
|
| ︙ | ︙ | |||
337 338 339 340 341 342 343 | * Implements [info object forward $objName $methodName] * * ---------------------------------------------------------------------- */ static int InfoObjectForwardCmd( | | | 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 |
* Implements [info object forward $objName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectForwardCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Tcl_HashEntry *hPtr;
Tcl_Obj *prefixObj;
|
| ︙ | ︙ | |||
394 395 396 397 398 399 400 | * Implements [info object isa $category $objName ...] * * ---------------------------------------------------------------------- */ static int InfoObjectIsACmd( | | | 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 |
* Implements [info object isa $category $objName ...]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectIsACmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
static const char *const categories[] = {
"class", "metaclass", "mixin", "object", "typeof", NULL
};
|
| ︙ | ︙ | |||
513 514 515 516 517 518 519 | * Implements [info object methods $objName ?$option ...?] * * ---------------------------------------------------------------------- */ static int InfoObjectMethodsCmd( | | | 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 |
* Implements [info object methods $objName ?$option ...?]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectMethodsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
FOREACH_HASH_DECLS;
|
| ︙ | ︙ | |||
633 634 635 636 637 638 639 | * Implements [info object methodtype $objName $methodName] * * ---------------------------------------------------------------------- */ static int InfoObjectMethodTypeCmd( | | | 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 |
* Implements [info object methodtype $objName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectMethodTypeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Tcl_HashEntry *hPtr;
Method *mPtr;
|
| ︙ | ︙ | |||
690 691 692 693 694 695 696 | * Implements [info object mixins $objName] * * ---------------------------------------------------------------------- */ static int InfoObjectMixinsCmd( | | | 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 |
* Implements [info object mixins $objName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectMixinsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *mixinPtr;
Object *oPtr;
Tcl_Obj *resultObj;
|
| ︙ | ︙ | |||
733 734 735 736 737 738 739 | * Implements [info object creationid $objName] * * ---------------------------------------------------------------------- */ static int InfoObjectIdCmd( | | | 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 |
* Implements [info object creationid $objName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectIdCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
765 766 767 768 769 770 771 | * Implements [info object namespace $objName] * * ---------------------------------------------------------------------- */ static int InfoObjectNsCmd( | | | 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 |
* Implements [info object namespace $objName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectNsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
798 799 800 801 802 803 804 | * Implements [info object variables $objName ?-private?] * * ---------------------------------------------------------------------- */ static int InfoObjectVariablesCmd( | | | 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 |
* Implements [info object variables $objName ?-private?]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectVariablesCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Tcl_Obj *resultObj;
int i, isPrivate = 0;
|
| ︙ | ︙ | |||
852 853 854 855 856 857 858 | * Implements [info object vars $objName ?$pattern?] * * ---------------------------------------------------------------------- */ static int InfoObjectVarsCmd( | | | 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 |
* Implements [info object vars $objName ?$pattern?]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectVarsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
const char *pattern = NULL;
FOREACH_HASH_DECLS;
|
| ︙ | ︙ | |||
913 914 915 916 917 918 919 | * Implements [info class constructor $clsName] * * ---------------------------------------------------------------------- */ static int InfoClassConstrCmd( | | | 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 |
* Implements [info class constructor $clsName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassConstrCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Proc *procPtr;
CompiledLocal *localPtr;
Tcl_Obj *resultObjs[2];
|
| ︙ | ︙ | |||
974 975 976 977 978 979 980 | * Implements [info class definition $clsName $methodName] * * ---------------------------------------------------------------------- */ static int InfoClassDefnCmd( | | | 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 |
* Implements [info class definition $clsName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassDefnCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_HashEntry *hPtr;
Proc *procPtr;
CompiledLocal *localPtr;
|
| ︙ | ︙ | |||
1042 1043 1044 1045 1046 1047 1048 | * Implements [info class definitionnamespace $clsName ?$kind?] * * ---------------------------------------------------------------------- */ static int InfoClassDefnNsCmd( | | | 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 |
* Implements [info class definitionnamespace $clsName ?$kind?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassDefnNsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
static const char *kindList[] = {
"-class",
"-instance",
|
| ︙ | ︙ | |||
1092 1093 1094 1095 1096 1097 1098 | * Implements [info class destructor $clsName] * * ---------------------------------------------------------------------- */ static int InfoClassDestrCmd( | | | 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 |
* Implements [info class destructor $clsName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassDestrCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Proc *procPtr;
Class *clsPtr;
|
| ︙ | ︙ | |||
1136 1137 1138 1139 1140 1141 1142 | * Implements [info class filters $clsName] * * ---------------------------------------------------------------------- */ static int InfoClassFiltersCmd( | | | 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 |
* Implements [info class filters $clsName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassFiltersCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int i;
Tcl_Obj *filterObj, *resultObj;
Class *clsPtr;
|
| ︙ | ︙ | |||
1174 1175 1176 1177 1178 1179 1180 | * Implements [info class forward $clsName $methodName] * * ---------------------------------------------------------------------- */ static int InfoClassForwardCmd( | | | 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 |
* Implements [info class forward $clsName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassForwardCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_HashEntry *hPtr;
Tcl_Obj *prefixObj;
Class *clsPtr;
|
| ︙ | ︙ | |||
1225 1226 1227 1228 1229 1230 1231 | * Implements [info class instances $clsName ?$pattern?] * * ---------------------------------------------------------------------- */ static int InfoClassInstancesCmd( | | | 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 |
* Implements [info class instances $clsName ?$pattern?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassInstancesCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Class *clsPtr;
int i;
|
| ︙ | ︙ | |||
1273 1274 1275 1276 1277 1278 1279 | * Implements [info class methods $clsName ?options...?] * * ---------------------------------------------------------------------- */ static int InfoClassMethodsCmd( | | | 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 |
* Implements [info class methods $clsName ?options...?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassMethodsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
Tcl_Obj *namePtr, *resultObj;
Method *mPtr;
|
| ︙ | ︙ | |||
1389 1390 1391 1392 1393 1394 1395 | * Implements [info class methodtype $clsName $methodName] * * ---------------------------------------------------------------------- */ static int InfoClassMethodTypeCmd( | | | 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 |
* Implements [info class methodtype $clsName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassMethodTypeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_HashEntry *hPtr;
Method *mPtr;
Class *clsPtr;
|
| ︙ | ︙ | |||
1441 1442 1443 1444 1445 1446 1447 | * Implements [info class mixins $clsName] * * ---------------------------------------------------------------------- */ static int InfoClassMixinsCmd( | | | 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 |
* Implements [info class mixins $clsName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassMixinsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr, *mixinPtr;
Tcl_Obj *resultObj;
int i;
|
| ︙ | ︙ | |||
1483 1484 1485 1486 1487 1488 1489 | * Implements [info class subclasses $clsName ?$pattern?] * * ---------------------------------------------------------------------- */ static int InfoClassSubsCmd( | | | 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 |
* Implements [info class subclasses $clsName ?$pattern?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassSubsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr, *subclassPtr;
Tcl_Obj *resultObj;
int i;
|
| ︙ | ︙ | |||
1538 1539 1540 1541 1542 1543 1544 | * Implements [info class superclasses $clsName] * * ---------------------------------------------------------------------- */ static int InfoClassSupersCmd( | | | 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 |
* Implements [info class superclasses $clsName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassSupersCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr, *superPtr;
Tcl_Obj *resultObj;
int i;
|
| ︙ | ︙ | |||
1577 1578 1579 1580 1581 1582 1583 | * Implements [info class variables $clsName ?-private?] * * ---------------------------------------------------------------------- */ static int InfoClassVariablesCmd( | | | 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 |
* Implements [info class variables $clsName ?-private?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassVariablesCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr;
Tcl_Obj *resultObj;
int i, isPrivate = 0;
|
| ︙ | ︙ | |||
1631 1632 1633 1634 1635 1636 1637 | * Implements [info object call $objName $methodName] * * ---------------------------------------------------------------------- */ static int InfoObjectCallCmd( | | | 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 |
* Implements [info object call $objName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectCallCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
CallContext *contextPtr;
|
| ︙ | ︙ | |||
1677 1678 1679 1680 1681 1682 1683 | * Implements [info class call $clsName $methodName] * * ---------------------------------------------------------------------- */ static int InfoClassCallCmd( | | | 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 |
* Implements [info class call $clsName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassCallCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr;
CallChain *callPtr;
|
| ︙ | ︙ |
Changes to generic/tclOOInt.h.
| ︙ | ︙ | |||
325 326 327 328 329 330 331 |
* The foundation of the object system within an interpreter contains
* references to the key classes and namespaces, together with a few other
* useful bits and pieces. Probably ought to eventually go in the Interp
* structure itself.
*/
typedef struct ThreadLocalData {
| | | | 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 |
* The foundation of the object system within an interpreter contains
* references to the key classes and namespaces, together with a few other
* useful bits and pieces. Probably ought to eventually go in the Interp
* structure itself.
*/
typedef struct ThreadLocalData {
size_t 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
* boundaries within a thread (objects don't
* generally cross threads). */
} ThreadLocalData;
typedef struct Foundation {
Tcl_Interp *interp;
Class *objectCls; /* The root of the object system. */
Class *classCls; /* The class of all classes. */
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
* of ensemble for this namespace. */
Tcl_Namespace *objdefNs; /* Namespace containing special commands for
* manipulating objects and classes. The
* "oo::objdefine" command acts as a special
|
| ︙ | ︙ |
Changes to generic/tclObj.c.
| ︙ | ︙ | |||
141 142 143 144 145 146 147 | * These are separated out so that some semantic content is attached * to them. */ #define ObjDeletionLock(contextPtr) ((contextPtr)->deletionCount++) #define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--) #define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0) #define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) | | | | | | | | | 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
* These are separated out so that some semantic content is attached
* to them.
*/
#define ObjDeletionLock(contextPtr) ((contextPtr)->deletionCount++)
#define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--)
#define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0)
#define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL)
#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) \
(objPtrVar) = (contextPtr)->deletionStack; \
(contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes
/*
* Macro to set up the local reference to the deletion context.
*/
#if !TCL_THREADS
static PendingObjData pendingObjData;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = &pendingObjData
#elif 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 *)Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData))
#endif
/*
* Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep
*/
#define PACK_BIGNUM(bignum, objPtr) \
if ((bignum).used > 0x7FFF) { \
mp_int *temp = (mp_int *)Tcl_Alloc(sizeof(mp_int)); \
*temp = bignum; \
(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 = (bignum).dp; \
(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \
| ((bignum).alloc << 15) | ((bignum).used)); \
}
/*
|
| ︙ | ︙ | |||
529 530 531 532 533 534 535 |
int num,
int *loc)
{
int newEntry;
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
| | | 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 |
int num,
int *loc)
{
int newEntry;
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_Alloc(offsetof(ContLineLoc, loc) + (num + 1) *sizeof(int));
if (!newEntry) {
/*
* We're entering ContLineLoc data for the same value more than one
* time. Taking care not to leak the old entry.
*
* This can happen when literals in a proc body are shared. See for
|
| ︙ | ︙ | |||
4219 4220 4221 4222 4223 4224 4225 |
Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0);
/*
* Stop shimmering and caching nothing when we found nothing. Just
* report the failure to find the command as an error.
*/
| | | 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 |
Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0);
/*
* Stop shimmering and caching nothing when we found nothing. Just
* report the failure to find the command as an error.
*/
if (cmdPtr == NULL || !TclRoutineHasName(cmdPtr)) {
return TCL_ERROR;
}
resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
if ((objPtr->typePtr == &tclCmdNameType) && (resPtr->refCount == 1)) {
/*
* Re-use existing ResolvedCmdName struct when possible.
|
| ︙ | ︙ |
Changes to generic/tclParse.c.
| ︙ | ︙ | |||
2102 2103 2104 2105 2106 2107 2108 |
const char *outerScript) /* continuation line data. This is set by
* EvalEx() to properly handle [...]-nested
* commands. The 'outerScript' refers to the
* most-outer script containing the embedded
* command, which is refered to by 'script'.
* The 'clNextOuter' refers to the current
* entry in the table of continuation lines in
| | | 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 |
const char *outerScript) /* continuation line data. This is set by
* EvalEx() to properly handle [...]-nested
* commands. The 'outerScript' refers to the
* most-outer script containing the embedded
* command, which is refered to by 'script'.
* The 'clNextOuter' refers to the current
* entry in the table of continuation lines in
* this "main script", and the character
* offsets are relative to the 'outerScript'
* as well.
*
* If outerScript == script, then this call is
* for words in the outer-most script or
* command. See Tcl_EvalEx and TclEvalObjEx
* for the places generating arguments for
|
| ︙ | ︙ |
Changes to generic/tclProc.c.
| ︙ | ︙ | |||
628 629 630 631 632 633 634 |
localPtr = localPtr->nextPtr;
} else {
/*
* Allocate an entry in the runtime procedure frame's array of
* local variables for the argument.
*/
| | > | 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 |
localPtr = localPtr->nextPtr;
} else {
/*
* Allocate an entry in the runtime procedure frame's array of
* local variables for the argument.
*/
localPtr = (CompiledLocal *)Tcl_Alloc(
offsetof(CompiledLocal, name) + fieldValues[0]->length + 1);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
procPtr->lastLocalPtr->nextPtr = localPtr;
procPtr->lastLocalPtr = localPtr;
}
localPtr->nextPtr = NULL;
|
| ︙ | ︙ | |||
1257 1258 1259 1260 1261 1262 1263 |
/*
* Cache the names and initial values of local variables; store the
* cache in both the framePtr for this execution and in the codePtr
* for future calls.
*/
| | | | 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 |
/*
* Cache the names and initial values of local variables; store the
* cache in both the framePtr for this execution and in the codePtr
* for future calls.
*/
localCachePtr = (LocalCache *)Tcl_Alloc(offsetof(LocalCache, varName0)
+ localCt * sizeof(Tcl_Obj *)
+ numArgs * sizeof(Var));
namePtr = &localCachePtr->varName0;
varPtr = (Var *) (namePtr + localCt);
localPtr = procPtr->firstLocalPtr;
while (localPtr) {
if (TclIsVarTemporary(localPtr)) {
|
| ︙ | ︙ |
Changes to generic/tclStringObj.c.
| ︙ | ︙ | |||
3450 3451 3452 3453 3454 3455 3456 |
Tcl_Obj *
TclStringFirst(
Tcl_Obj *needle,
Tcl_Obj *haystack,
size_t start)
{
size_t lh = 0, ln = Tcl_GetCharLength(needle);
| < | | 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 |
Tcl_Obj *
TclStringFirst(
Tcl_Obj *needle,
Tcl_Obj *haystack,
size_t start)
{
size_t lh = 0, ln = Tcl_GetCharLength(needle);
size_t value = TCL_INDEX_NONE;
Tcl_UniChar *check, *end, *uh, *un;
if (start == TCL_INDEX_NONE) {
start = 0;
}
if (ln == 0) {
/* We don't find empty substrings. Bizarre!
|
| ︙ | ︙ | |||
3528 3529 3530 3531 3532 3533 3534 |
if ((*check == *un) && (0 ==
memcmp(check + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) {
value = (check - uh);
goto firstEnd;
}
}
firstEnd:
| | < | 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 |
if ((*check == *un) && (0 ==
memcmp(check + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) {
value = (check - uh);
goto firstEnd;
}
}
firstEnd:
return TclNewWideIntObjFromSize(value);
}
/*
*---------------------------------------------------------------------------
*
* TclStringLast --
*
|
| ︙ | ︙ | |||
3557 3558 3559 3560 3561 3562 3563 |
Tcl_Obj *
TclStringLast(
Tcl_Obj *needle,
Tcl_Obj *haystack,
size_t last)
{
size_t lh = 0, ln = Tcl_GetCharLength(needle);
| < | | 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 |
Tcl_Obj *
TclStringLast(
Tcl_Obj *needle,
Tcl_Obj *haystack,
size_t last)
{
size_t lh = 0, ln = Tcl_GetCharLength(needle);
size_t value = TCL_INDEX_NONE;
Tcl_UniChar *check, *uh, *un;
if (ln == 0) {
/*
* We don't find empty substrings. Bizarre!
*
* TODO: When we one day make this a true substring
|
| ︙ | ︙ | |||
3615 3616 3617 3618 3619 3620 3621 |
&& (0 == memcmp(check+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) {
value = (check - uh);
goto lastEnd;
}
check--;
}
lastEnd:
| | < | 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 |
&& (0 == memcmp(check+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) {
value = (check - uh);
goto lastEnd;
}
check--;
}
lastEnd:
return TclNewWideIntObjFromSize(value);
}
/*
*---------------------------------------------------------------------------
*
* TclStringReverse --
*
|
| ︙ | ︙ |
Changes to generic/tclStringRep.h.
| ︙ | ︙ | |||
59 60 61 62 63 64 65 |
size_t allocated; /* The amount of space actually allocated for
* the UTF string (minus 1 byte for the
* termination char). */
size_t maxChars; /* Max number of chars that can fit in the
* space allocated for the unicode array. */
int hasUnicode; /* Boolean determining whether the string has
* a Unicode representation. */
| | | | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 |
size_t allocated; /* The amount of space actually allocated for
* the UTF string (minus 1 byte for the
* termination char). */
size_t maxChars; /* Max number of chars that can fit in the
* space allocated for the unicode array. */
int hasUnicode; /* Boolean determining whether the string has
* a Unicode representation. */
Tcl_UniChar unicode[TCLFLEXARRAY]; /* The array of Unicode chars. The actual size
* of this field depends on the 'maxChars'
* field above. */
} String;
#define STRING_SIZE(numChars) \
(offsetof(String, unicode) + ((numChars + 1) * sizeof(Tcl_UniChar)))
#define stringAttemptAlloc(numChars) \
(String *) Tcl_AttemptAlloc(STRING_SIZE(numChars))
#define stringAlloc(numChars) \
(String *) Tcl_Alloc(STRING_SIZE(numChars))
#define stringRealloc(ptr, numChars) \
(String *) Tcl_Realloc((ptr), STRING_SIZE(numChars))
#define stringAttemptRealloc(ptr, numChars) \
|
| ︙ | ︙ |
Changes to generic/tclStubInit.c.
| ︙ | ︙ | |||
851 852 853 854 855 856 857 |
Tcl_CreateCloseHandler, /* 90 */
Tcl_CreateCommand, /* 91 */
Tcl_CreateEventSource, /* 92 */
Tcl_CreateExitHandler, /* 93 */
Tcl_CreateInterp, /* 94 */
0, /* 95 */
Tcl_CreateObjCommand, /* 96 */
| | | 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 |
Tcl_CreateCloseHandler, /* 90 */
Tcl_CreateCommand, /* 91 */
Tcl_CreateEventSource, /* 92 */
Tcl_CreateExitHandler, /* 93 */
Tcl_CreateInterp, /* 94 */
0, /* 95 */
Tcl_CreateObjCommand, /* 96 */
Tcl_CreateChild, /* 97 */
Tcl_CreateTimerHandler, /* 98 */
Tcl_CreateTrace, /* 99 */
Tcl_DeleteAssocData, /* 100 */
Tcl_DeleteChannelHandler, /* 101 */
Tcl_DeleteCloseHandler, /* 102 */
Tcl_DeleteCommand, /* 103 */
Tcl_DeleteCommandFromToken, /* 104 */
|
| ︙ | ︙ | |||
918 919 920 921 922 923 924 |
Tcl_GetChannelOption, /* 157 */
Tcl_GetChannelType, /* 158 */
Tcl_GetCommandInfo, /* 159 */
Tcl_GetCommandName, /* 160 */
Tcl_GetErrno, /* 161 */
Tcl_GetHostName, /* 162 */
Tcl_GetInterpPath, /* 163 */
| | | | 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 |
Tcl_GetChannelOption, /* 157 */
Tcl_GetChannelType, /* 158 */
Tcl_GetCommandInfo, /* 159 */
Tcl_GetCommandName, /* 160 */
Tcl_GetErrno, /* 161 */
Tcl_GetHostName, /* 162 */
Tcl_GetInterpPath, /* 163 */
Tcl_GetParent, /* 164 */
Tcl_GetNameOfExecutable, /* 165 */
Tcl_GetObjResult, /* 166 */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
Tcl_GetOpenFile, /* 167 */
#endif /* UNIX */
#if defined(_WIN32) /* WIN */
0, /* 167 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
Tcl_GetOpenFile, /* 167 */
#endif /* MACOSX */
Tcl_GetPathType, /* 168 */
Tcl_Gets, /* 169 */
Tcl_GetsObj, /* 170 */
Tcl_GetServiceMode, /* 171 */
Tcl_GetChild, /* 172 */
Tcl_GetStdChannel, /* 173 */
0, /* 174 */
0, /* 175 */
Tcl_GetVar2, /* 176 */
0, /* 177 */
0, /* 178 */
Tcl_HideCommand, /* 179 */
|
| ︙ | ︙ |
Changes to generic/tclTest.c.
| ︙ | ︙ | |||
723 724 725 726 727 728 729 | * Creates, deletes, and invokes handlers. * *---------------------------------------------------------------------- */ static int TestasyncCmd( | | | 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 |
* Creates, deletes, and invokes handlers.
*
*----------------------------------------------------------------------
*/
static int
TestasyncCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
TestAsyncHandler *asyncPtr, *prevPtr;
int id, code;
static int nextId = 1;
|
| ︙ | ︙ | |||
934 935 936 937 938 939 940 |
Tcl_ExitThread(TCL_OK);
TCL_THREAD_CREATE_RETURN;
}
#endif
static int
TestbumpinterpepochObjCmd(
| | | 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 |
Tcl_ExitThread(TCL_OK);
TCL_THREAD_CREATE_RETURN;
}
#endif
static int
TestbumpinterpepochObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *)interp;
if (objc != 1) {
|
| ︙ | ︙ | |||
969 970 971 972 973 974 975 | * Creates and deletes various commands and modifies their data. * *---------------------------------------------------------------------- */ static int TestcmdinfoCmd( | | | 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 |
* Creates and deletes various commands and modifies their data.
*
*----------------------------------------------------------------------
*/
static int
TestcmdinfoCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_CmdInfo info;
if (argc != 3) {
|
| ︙ | ︙ | |||
1096 1097 1098 1099 1100 1101 1102 | * Creates and deletes various commands and modifies their data. * *---------------------------------------------------------------------- */ static int TestcmdtokenCmd( | | | 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 |
* Creates and deletes various commands and modifies their data.
*
*----------------------------------------------------------------------
*/
static int
TestcmdtokenCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_Command token;
int *l;
char buf[30];
|
| ︙ | ︙ | |||
1159 1160 1161 1162 1163 1164 1165 | * a procedure by the command trace. * *---------------------------------------------------------------------- */ static int TestcmdtraceCmd( | | | 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 |
* a procedure by the command trace.
*
*----------------------------------------------------------------------
*/
static int
TestcmdtraceCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_DString buffer;
int result;
|
| ︙ | ︙ | |||
1256 1257 1258 1259 1260 1261 1262 |
* command and arguments are appended.
* Accumulates test result. */
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*level*/,
char *command, /* The command being traced (after
* substitutions). */
TCL_UNUSED(Tcl_CmdProc *) /*cmdProc*/,
| | | | | | 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 |
* command and arguments are appended.
* Accumulates test result. */
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*level*/,
char *command, /* The command being traced (after
* substitutions). */
TCL_UNUSED(Tcl_CmdProc *) /*cmdProc*/,
TCL_UNUSED(void *),
int argc, /* Number of arguments. */
const char *argv[]) /* Argument strings. */
{
Tcl_DString *bufPtr = (Tcl_DString *) clientData;
int i;
Tcl_DStringAppendElement(bufPtr, command);
Tcl_DStringStartSublist(bufPtr);
for (i = 0; i < argc; i++) {
Tcl_DStringAppendElement(bufPtr, argv[i]);
}
Tcl_DStringEndSublist(bufPtr);
}
static void
CmdTraceDeleteProc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*level*/,
TCL_UNUSED(char *) /*command*/,
TCL_UNUSED(Tcl_CmdProc *),
TCL_UNUSED(void *),
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
/*
* Remove ourselves to test whether calling Tcl_DeleteTrace within a trace
* callback causes the for loop in TclNRExecuteByteCode that calls traces to
* reference freed memory.
*/
Tcl_DeleteTrace(interp, cmdTrace);
}
static int
ObjTraceProc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
TCL_UNUSED(int) /*level*/,
const char *command,
TCL_UNUSED(Tcl_Command),
TCL_UNUSED(int) /*objc*/,
Tcl_Obj *const objv[]) /* Argument objects. */
{
|
| ︙ | ︙ | |||
1351 1352 1353 1354 1355 1356 1357 | * and "value:at:"). * *---------------------------------------------------------------------- */ static int TestcreatecommandCmd( | | | 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 |
* and "value:at:").
*
*----------------------------------------------------------------------
*/
static int
TestcreatecommandCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option\"", NULL);
|
| ︙ | ︙ | |||
1381 1382 1383 1384 1385 1386 1387 |
return TCL_ERROR;
}
return TCL_OK;
}
static int
CreatedCommandProc(
| | | 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 |
return TCL_ERROR;
}
return TCL_OK;
}
static int
CreatedCommandProc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
Tcl_CmdInfo info;
int found;
|
| ︙ | ︙ | |||
1403 1404 1405 1406 1407 1408 1409 |
Tcl_AppendResult(interp, "CreatedCommandProc in ",
info.namespacePtr->fullName, NULL);
return TCL_OK;
}
static int
CreatedCommandProc2(
| | | 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 |
Tcl_AppendResult(interp, "CreatedCommandProc in ",
info.namespacePtr->fullName, NULL);
return TCL_OK;
}
static int
CreatedCommandProc2(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
Tcl_CmdInfo info;
int found;
|
| ︙ | ︙ | |||
1441 1442 1443 1444 1445 1446 1447 | * Creates and deletes interpreters. * *---------------------------------------------------------------------- */ static int TestdcallCmd( | | | 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 |
* Creates and deletes interpreters.
*
*----------------------------------------------------------------------
*/
static int
TestdcallCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int i, id;
delInterp = Tcl_CreateInterp();
|
| ︙ | ︙ | |||
1505 1506 1507 1508 1509 1510 1511 | * Creates a command. * *---------------------------------------------------------------------- */ static int TestdelCmd( | | | | | | | 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 |
* Creates a command.
*
*----------------------------------------------------------------------
*/
static int
TestdelCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
DelCmd *dPtr;
Tcl_Interp *child;
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
child = Tcl_GetChild(interp, argv[1]);
if (child == NULL) {
return TCL_ERROR;
}
dPtr = (DelCmd *)Tcl_Alloc(sizeof(DelCmd));
dPtr->interp = interp;
dPtr->deleteCmd = (char *)Tcl_Alloc(strlen(argv[3]) + 1);
strcpy(dPtr->deleteCmd, argv[3]);
Tcl_CreateCommand(child, argv[2], DelCmdProc, dPtr,
DelDeleteProc);
return TCL_OK;
}
static int
DelCmdProc(
void *clientData, /* String result to return. */
|
| ︙ | ︙ | |||
1580 1581 1582 1583 1584 1585 1586 | * interpreter. * *---------------------------------------------------------------------- */ static int TestdelassocdataCmd( | | | 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 |
* interpreter.
*
*----------------------------------------------------------------------
*/
static int
TestdelassocdataCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" data_key\"", NULL);
|
| ︙ | ︙ | |||
1617 1618 1619 1620 1621 1622 1623 | * shorten - Indicates that the 'shorten' flag should be passed in. * *----------------------------------------------------------------------------- */ static int TestdoubledigitsObjCmd( | | | 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 |
* shorten - Indicates that the 'shorten' flag should be passed in.
*
*-----------------------------------------------------------------------------
*/
static int
TestdoubledigitsObjCmd(
TCL_UNUSED(void *),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj* const objv[]) /* Parameter vector */
{
static const char* options[] = {
"shortest",
"e",
|
| ︙ | ︙ | |||
1704 1705 1706 1707 1708 1709 1710 | * Creates, deletes, and invokes handlers. * *---------------------------------------------------------------------- */ static int TestdstringCmd( | | | 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 |
* Creates, deletes, and invokes handlers.
*
*----------------------------------------------------------------------
*/
static int
TestdstringCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int count;
if (argc < 2) {
|
| ︙ | ︙ | |||
1830 1831 1832 1833 1834 1835 1836 | * Load encodings. * *---------------------------------------------------------------------- */ static int TestencodingObjCmd( | | | 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 |
* Load encodings.
*
*----------------------------------------------------------------------
*/
static int
TestencodingObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Encoding encoding;
int index, length;
const char *string;
|
| ︙ | ︙ | |||
1990 1991 1992 1993 1994 1995 1996 | * None. * *---------------------------------------------------------------------- */ static int TestevalexObjCmd( | | | 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestevalexObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length, flags;
const char *script;
|
| ︙ | ︙ | |||
2035 2036 2037 2038 2039 2040 2041 | * None. * *---------------------------------------------------------------------- */ static int TestevalobjvObjCmd( | | | 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestevalobjvObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int evalGlobal;
if (objc < 3) {
|
| ︙ | ︙ | |||
2084 2085 2086 2087 2088 2089 2090 | * Manipulates the event queue as directed. * *---------------------------------------------------------------------- */ static int TesteventObjCmd( | | | 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 |
* Manipulates the event queue as directed.
*
*----------------------------------------------------------------------
*/
static int
TesteventObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter vector */
{
static const char *const subcommands[] = { /* Possible subcommands */
"queue", "delete", NULL
};
|
| ︙ | ︙ | |||
2263 2264 2265 2266 2267 2268 2269 | * None. * *---------------------------------------------------------------------- */ static int TestexithandlerCmd( | | | 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexithandlerCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int value;
if (argc != 3) {
|
| ︙ | ︙ | |||
2339 2340 2341 2342 2343 2344 2345 | * None. * *---------------------------------------------------------------------- */ static int TestexprlongCmd( | | | 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprlongCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
long exprResult;
char buf[4 + TCL_INTEGER_SPACE];
int result;
|
| ︙ | ︙ | |||
2382 2383 2384 2385 2386 2387 2388 | * None. * *---------------------------------------------------------------------- */ static int TestexprlongobjCmd( | | | 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprlongobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument objects. */
{
long exprResult;
char buf[4 + TCL_INTEGER_SPACE];
int result;
|
| ︙ | ︙ | |||
2424 2425 2426 2427 2428 2429 2430 | * None. * *---------------------------------------------------------------------- */ static int TestexprdoubleCmd( | | | 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprdoubleCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
double exprResult;
char buf[4 + TCL_DOUBLE_SPACE];
int result;
|
| ︙ | ︙ | |||
2468 2469 2470 2471 2472 2473 2474 | * None. * *---------------------------------------------------------------------- */ static int TestexprdoubleobjCmd( | | | 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprdoubleobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument objects. */
{
double exprResult;
char buf[4 + TCL_DOUBLE_SPACE];
int result;
|
| ︙ | ︙ | |||
2510 2511 2512 2513 2514 2515 2516 | * None. * *---------------------------------------------------------------------- */ static int TestexprstringCmd( | | | 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprstringCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" expression\"", NULL);
|
| ︙ | ︙ | |||
2542 2543 2544 2545 2546 2547 2548 | * May create a link on disk. * *---------------------------------------------------------------------- */ static int TestfilelinkCmd( | | | 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 |
* May create a link on disk.
*
*----------------------------------------------------------------------
*/
static int
TestfilelinkCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Obj *contents;
if (objc < 2 || objc > 3) {
|
| ︙ | ︙ | |||
2609 2610 2611 2612 2613 2614 2615 | * None. * *---------------------------------------------------------------------- */ static int TestgetassocdataCmd( | | | 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetassocdataCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
char *res;
if (argc != 2) {
|
| ︙ | ︙ | |||
2647 2648 2649 2650 2651 2652 2653 | * None. * *---------------------------------------------------------------------- */ static int TestgetplatformCmd( | | | 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetplatformCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
static const char *const platformStrings[] = { "unix", "mac", "windows" };
TclPlatformType *platform;
|
| ︙ | ︙ | |||
2687 2688 2689 2690 2691 2692 2693 | * Deletes one or more interpreters. * *---------------------------------------------------------------------- */ static int TestinterpdeleteCmd( | | | | | | | 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 |
* Deletes one or more interpreters.
*
*----------------------------------------------------------------------
*/
static int
TestinterpdeleteCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_Interp *childToDelete;
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" path\"", NULL);
return TCL_ERROR;
}
childToDelete = Tcl_GetChild(interp, argv[1]);
if (childToDelete == NULL) {
return TCL_ERROR;
}
Tcl_DeleteInterp(childToDelete);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestlinkCmd --
|
| ︙ | ︙ | |||
2727 2728 2729 2730 2731 2732 2733 | * values of the linked variables. * *---------------------------------------------------------------------- */ static int TestlinkCmd( | | | 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 |
* values of the linked variables.
*
*----------------------------------------------------------------------
*/
static int
TestlinkCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
static int intVar = 43;
static int boolVar = 4;
static double realVar = 1.23;
|
| ︙ | ︙ | |||
3195 3196 3197 3198 3199 3200 3201 | * Creates, deletes, and invokes variable links. * *---------------------------------------------------------------------- */ static int TestlinkarrayCmd( | | | 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 |
* Creates, deletes, and invokes variable links.
*
*----------------------------------------------------------------------
*/
static int
TestlinkarrayCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *LinkOption[] = {
"update", "remove", "create", NULL
};
|
| ︙ | ︙ | |||
3313 3314 3315 3316 3317 3318 3319 | * Modifies the current C locale. * *---------------------------------------------------------------------- */ static int TestlocaleCmd( | | | 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 |
* Modifies the current C locale.
*
*----------------------------------------------------------------------
*/
static int
TestlocaleCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int index;
const char *locale;
static const char *const optionStrings[] = {
|
| ︙ | ︙ | |||
3399 3400 3401 3402 3403 3404 3405 | * None. * *---------------------------------------------------------------------- */ static int TestparserObjCmd( | | | 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparserObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
int length, dummy;
Tcl_Parse parse;
|
| ︙ | ︙ | |||
3455 3456 3457 3458 3459 3460 3461 | * None. * *---------------------------------------------------------------------- */ static int TestexprparserObjCmd( | | | 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprparserObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
int length, dummy;
Tcl_Parse parse;
|
| ︙ | ︙ | |||
3602 3603 3604 3605 3606 3607 3608 | * None. * *---------------------------------------------------------------------- */ static int TestparsevarObjCmd( | | | 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparsevarObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *value, *name, *termPtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
3643 3644 3645 3646 3647 3648 3649 | * None. * *---------------------------------------------------------------------- */ static int TestparsevarnameObjCmd( | | | 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparsevarnameObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
int append, length, dummy;
Tcl_Parse parse;
|
| ︙ | ︙ | |||
3706 3707 3708 3709 3710 3711 3712 | * None. * *---------------------------------------------------------------------- */ static int TestpreferstableObjCmd( | | | 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestpreferstableObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
Interp *iPtr = (Interp *) interp;
iPtr->packagePrefer = PKG_PREFER_STABLE;
|
| ︙ | ︙ | |||
3736 3737 3738 3739 3740 3741 3742 | * None. * *---------------------------------------------------------------------- */ static int TestprintObjCmd( | | | 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestprintObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_WideInt argv1 = 0;
size_t argv2;
|
| ︙ | ︙ | |||
3777 3778 3779 3780 3781 3782 3783 | * See the user documentation. * *---------------------------------------------------------------------- */ static int TestregexpObjCmd( | | | 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
TestregexpObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, indices, stringLength, match, about;
size_t ii;
int hasxflags, cflags, eflags;
|
| ︙ | ︙ | |||
4102 4103 4104 4105 4106 4107 4108 | * See the user documentation. * *---------------------------------------------------------------------- */ static int TestreturnObjCmd( | | | 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
TestreturnObjCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
return TCL_RETURN;
}
|
| ︙ | ︙ | |||
4130 4131 4132 4133 4134 4135 4136 | * data for this interpreter. * *---------------------------------------------------------------------- */ static int TestsetassocdataCmd( | | | 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 |
* data for this interpreter.
*
*----------------------------------------------------------------------
*/
static int
TestsetassocdataCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
char *buf, *oldData;
Tcl_InterpDeleteProc *procPtr;
|
| ︙ | ︙ | |||
4181 4182 4183 4184 4185 4186 4187 | * Sets the tclPlatform global variable. * *---------------------------------------------------------------------- */ static int TestsetplatformCmd( | | | 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 |
* Sets the tclPlatform global variable.
*
*----------------------------------------------------------------------
*/
static int
TestsetplatformCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
size_t length;
TclPlatformType *platform;
|
| ︙ | ︙ | |||
4230 4231 4232 4233 4234 4235 4236 | * variable "x" in that interpreter is set to "loaded". * *---------------------------------------------------------------------- */ static int TeststaticpkgCmd( | | | 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 |
* variable "x" in that interpreter is set to "loaded".
*
*----------------------------------------------------------------------
*/
static int
TeststaticpkgCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int safe, loaded;
if (argc != 4) {
|
| ︙ | ︙ | |||
4281 4282 4283 4284 4285 4286 4287 | * None. * *---------------------------------------------------------------------- */ static int TesttranslatefilenameCmd( | | | 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TesttranslatefilenameCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_DString buffer;
const char *result;
|
| ︙ | ︙ | |||
4322 4323 4324 4325 4326 4327 4328 | * Creates or modifies an "upvar" reference. * *---------------------------------------------------------------------- */ static int TestupvarCmd( | | | 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 |
* Creates or modifies an "upvar" reference.
*
*----------------------------------------------------------------------
*/
static int
TestupvarCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int flags = 0;
if ((argc != 5) && (argc != 6)) {
|
| ︙ | ︙ | |||
4374 4375 4376 4377 4378 4379 4380 | * None. * *---------------------------------------------------------------------- */ static int TestseterrorcodeCmd( | | | 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestseterrorcodeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
if (argc > 6) {
Tcl_AppendResult(interp, "too many args", NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
4426 4427 4428 4429 4430 4431 4432 | * None. * *---------------------------------------------------------------------- */ static int TestsetobjerrorcodeCmd( | | | 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsetobjerrorcodeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_SetObjErrorCode(interp, Tcl_ConcatObj(objc - 1, objv + 1));
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
4454 4455 4456 4457 4458 4459 4460 | * Creates and deletes interpreters. * *---------------------------------------------------------------------- */ static int TestfeventCmd( | | | 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 |
* Creates and deletes interpreters.
*
*----------------------------------------------------------------------
*/
static int
TestfeventCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
static Tcl_Interp *interp2 = NULL;
int code;
Tcl_Channel chan;
|
| ︙ | ︙ | |||
4526 4527 4528 4529 4530 4531 4532 | * May exit application. * *---------------------------------------------------------------------- */ static int TestpanicCmd( | | | | 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 |
* May exit application.
*
*----------------------------------------------------------------------
*/
static int
TestpanicCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
/*
* Put the arguments into a var args structure
* Append all of the arguments together separated by spaces
*/
char *argString = Tcl_Merge(argc-1, argv+1);
Tcl_Panic("%s", argString);
Tcl_Free(argString);
return TCL_OK;
}
static int
TestfileCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
Tcl_Obj *const argv[]) /* The argument objects. */
{
int force, i, j, result;
Tcl_Obj *error = NULL;
const char *subcmd;
|
| ︙ | ︙ | |||
4627 4628 4629 4630 4631 4632 4633 | * None. * *---------------------------------------------------------------------- */ static int TestgetvarfullnameCmd( | | | 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetvarfullnameCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *name, *arg;
int flags = 0;
Tcl_Namespace *namespacePtr;
|
| ︙ | ︙ | |||
4701 4702 4703 4704 4705 4706 4707 | * Allocates and frees memory, sets a variable "a" in the interpreter. * *---------------------------------------------------------------------- */ static int GetTimesObjCmd( | | | 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 |
* Allocates and frees memory, sets a variable "a" in the interpreter.
*
*----------------------------------------------------------------------
*/
static int
GetTimesObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The current interpreter. */
TCL_UNUSED(int) /*cobjc*/,
TCL_UNUSED(Tcl_Obj *const *) /*cobjv*/)
{
Interp *iPtr = (Interp *) interp;
int i, n;
double timePer;
|
| ︙ | ︙ | |||
4880 4881 4882 4883 4884 4885 4886 | * None. * *---------------------------------------------------------------------- */ static int NoopCmd( | | | 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 |
* None.
*
*----------------------------------------------------------------------
*/
static int
NoopCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
return TCL_OK;
}
|
| ︙ | ︙ | |||
4907 4908 4909 4910 4911 4912 4913 | * None. * *---------------------------------------------------------------------- */ static int NoopObjCmd( | | | 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 |
* None.
*
*----------------------------------------------------------------------
*/
static int
NoopObjCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
return TCL_OK;
}
|
| ︙ | ︙ | |||
4932 4933 4934 4935 4936 4937 4938 | * None. * *---------------------------------------------------------------------- */ static int TeststringbytesObjCmd( | | | 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TeststringbytesObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int n;
const unsigned char *p;
|
| ︙ | ︙ | |||
4972 4973 4974 4975 4976 4977 4978 | * None. * *---------------------------------------------------------------------- */ static int TestpurebytesobjObjCmd( | | | 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestpurebytesobjObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Obj *objPtr;
if (objc > 2) {
|
| ︙ | ︙ | |||
5019 5020 5021 5022 5023 5024 5025 | * None. * *---------------------------------------------------------------------- */ static int TestsetbytearraylengthObjCmd( | | | 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsetbytearraylengthObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int n;
Tcl_Obj *obj = NULL;
|
| ︙ | ︙ | |||
5063 5064 5065 5066 5067 5068 5069 | * None. * *---------------------------------------------------------------------- */ static int TestbytestringObjCmd( | | | 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestbytestringObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
size_t n = 0;
const char *p;
|
| ︙ | ︙ | |||
5185 5186 5187 5188 5189 5190 5191 | * None. * *---------------------------------------------------------------------- */ static int TestsaveresultCmd( | | | 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsaveresultCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,/* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int discard, result, index;
Tcl_SavedResult state;
Tcl_Obj *objPtr;
|
| ︙ | ︙ | |||
5312 5313 5314 5315 5316 5317 5318 | * None. * *---------------------------------------------------------------------- */ static int TestmainthreadCmd( | | | 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestmainthreadCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
TCL_UNUSED(const char **) /*argv*/)
{
if (argc == 1) {
Tcl_Obj *idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
|
| ︙ | ︙ | |||
5373 5374 5375 5376 5377 5378 5379 | * None. * *---------------------------------------------------------------------- */ static int TestsetmainloopCmd( | | | 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsetmainloopCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
exitMainLoop = 0;
Tcl_SetMainLoop(MainLoop);
return TCL_OK;
|
| ︙ | ︙ | |||
5402 5403 5404 5405 5406 5407 5408 | * None. * *---------------------------------------------------------------------- */ static int TestexitmainloopCmd( | | | 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexitmainloopCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
exitMainLoop = 1;
return TCL_OK;
}
|
| ︙ | ︙ | |||
5430 5431 5432 5433 5434 5435 5436 | * None. * *---------------------------------------------------------------------- */ static int TestChannelCmd( | | | 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestChannelCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter for result. */
int argc, /* Count of additional args. */
const char **argv) /* Additional arg strings. */
{
const char *cmdName; /* Sub command. */
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_HashSearch hSearch; /* Search variable. */
|
| ︙ | ︙ | |||
5897 5898 5899 5900 5901 5902 5903 | * Creates, deletes and returns channel event handlers. * *---------------------------------------------------------------------- */ static int TestChannelEventCmd( | | | 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 |
* Creates, deletes and returns channel event handlers.
*
*----------------------------------------------------------------------
*/
static int
TestChannelEventCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_Obj *resultListPtr;
Channel *chanPtr;
ChannelState *statePtr; /* state info for channel */
|
| ︙ | ︙ | |||
6109 6110 6111 6112 6113 6114 6115 | * None. * *---------------------------------------------------------------------- */ static int TestSocketCmd( | | | 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestSocketCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter for result. */
int argc, /* Count of additional args. */
const char **argv) /* Additional arg strings. */
{
const char *cmdName; /* Sub command. */
size_t len; /* Length of subcommand string. */
|
| ︙ | ︙ | |||
6180 6181 6182 6183 6184 6185 6186 | * May change the ServiceMode setting. * *---------------------------------------------------------------------- */ static int TestServiceModeCmd( | | | 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 |
* May change the ServiceMode setting.
*
*----------------------------------------------------------------------
*/
static int
TestServiceModeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int newmode, oldmode;
if (argc > 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
| ︙ | ︙ | |||
6224 6225 6226 6227 6228 6229 6230 | * Sets interpreter result. * *---------------------------------------------------------------------- */ static int TestWrongNumArgsObjCmd( | | | 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 |
* Sets interpreter result.
*
*----------------------------------------------------------------------
*/
static int
TestWrongNumArgsObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, length;
const char *msg;
|
| ︙ | ︙ | |||
6280 6281 6282 6283 6284 6285 6286 | * Sets interpreter result. * *---------------------------------------------------------------------- */ static int TestGetIndexFromObjStructObjCmd( | | | 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 |
* Sets interpreter result.
*
*----------------------------------------------------------------------
*/
static int
TestGetIndexFromObjStructObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *const ary[] = {
"a", "b", "c", "d", "e", "f", NULL, NULL
};
|
| ︙ | ︙ | |||
6334 6335 6336 6337 6338 6339 6340 | * Inserts or removes a filesystem from Tcl's stack. * *---------------------------------------------------------------------- */ static int TestFilesystemObjCmd( | | | 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 |
* Inserts or removes a filesystem from Tcl's stack.
*
*----------------------------------------------------------------------
*/
static int
TestFilesystemObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int res, boolVal;
const char *msg;
|
| ︙ | ︙ | |||
6676 6677 6678 6679 6680 6681 6682 |
TestReport("normalizepath", pathPtr, NULL);
return nextCheckpoint;
}
static int
SimplePathInFilesystem(
Tcl_Obj *pathPtr,
| | | 6676 6677 6678 6679 6680 6681 6682 6683 6684 6685 6686 6687 6688 6689 6690 |
TestReport("normalizepath", pathPtr, NULL);
return nextCheckpoint;
}
static int
SimplePathInFilesystem(
Tcl_Obj *pathPtr,
TCL_UNUSED(void **))
{
const char *str = Tcl_GetString(pathPtr);
if (strncmp(str, "simplefs:/", 10)) {
return -1;
}
return TCL_OK;
|
| ︙ | ︙ | |||
6705 6706 6707 6708 6709 6710 6711 | * Please do not consider this filesystem a model of how things are to be * done. It is quite the opposite! But, it does allow us to test some * important features. */ static int TestSimpleFilesystemObjCmd( | | | 6705 6706 6707 6708 6709 6710 6711 6712 6713 6714 6715 6716 6717 6718 6719 |
* Please do not consider this filesystem a model of how things are to be
* done. It is quite the opposite! But, it does allow us to test some
* important features.
*/
static int
TestSimpleFilesystemObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int res, boolVal;
const char *msg;
|
| ︙ | ︙ | |||
6968 6969 6970 6971 6972 6973 6974 | /* * Used to check correct string-length determining in Tcl_NumUtfChars */ static int TestNumUtfCharsCmd( | | | 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 |
/*
* Used to check correct string-length determining in Tcl_NumUtfChars
*/
static int
TestNumUtfCharsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
size_t len, limit = TCL_INDEX_NONE;
const char *bytes = Tcl_GetString(objv[1]);
|
| ︙ | ︙ | |||
6998 6999 7000 7001 7002 7003 7004 | /* * Used to check correct operation of Tcl_UtfFindFirst */ static int TestFindFirstCmd( | | | 6998 6999 7000 7001 7002 7003 7004 7005 7006 7007 7008 7009 7010 7011 7012 |
/*
* Used to check correct operation of Tcl_UtfFindFirst
*/
static int
TestFindFirstCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
int len = -1;
|
| ︙ | ︙ | |||
7020 7021 7022 7023 7024 7025 7026 | /* * Used to check correct operation of Tcl_UtfFindLast */ static int TestFindLastCmd( | | | 7020 7021 7022 7023 7024 7025 7026 7027 7028 7029 7030 7031 7032 7033 7034 |
/*
* Used to check correct operation of Tcl_UtfFindLast
*/
static int
TestFindLastCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
int len = -1;
|
| ︙ | ︙ | |||
7062 7063 7064 7065 7066 7067 7068 | * None. * *---------------------------------------------------------------------- */ static int TestcpuidCmd( | | | 7062 7063 7064 7065 7066 7067 7068 7069 7070 7071 7072 7073 7074 7075 7076 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestcpuidCmd(
TCL_UNUSED(void *),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const * objv) /* Parameter vector */
{
int status, index, i;
int regs[4];
Tcl_Obj *regsObjs[4];
|
| ︙ | ︙ | |||
7098 7099 7100 7101 7102 7103 7104 | /* * Used to do basic checks of the TCL_HASH_KEY_SYSTEM_HASH flag */ static int TestHashSystemHashCmd( | | | 7098 7099 7100 7101 7102 7103 7104 7105 7106 7107 7108 7109 7110 7111 7112 |
/*
* Used to do basic checks of the TCL_HASH_KEY_SYSTEM_HASH flag
*/
static int
TestHashSystemHashCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
static const Tcl_HashKeyType hkType = {
TCL_HASH_KEY_TYPE_VERSION, TCL_HASH_KEY_SYSTEM_HASH,
NULL, NULL, NULL, NULL
|
| ︙ | ︙ | |||
7174 7175 7176 7177 7178 7179 7180 | /* * Used for testing Tcl_GetInt which is no longer used directly by the * core very much. */ static int TestgetintCmd( | | | 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 |
/*
* Used for testing Tcl_GetInt which is no longer used directly by the
* core very much.
*/
static int
TestgetintCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int argc,
const char **argv)
{
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
7201 7202 7203 7204 7205 7206 7207 | } /* * Used for determining sizeof(long) at script level. */ static int TestlongsizeCmd( | | | 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 7214 7215 |
}
/*
* Used for determining sizeof(long) at script level.
*/
static int
TestlongsizeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int argc,
TCL_UNUSED(const char **) /*argv*/)
{
if (argc != 1) {
Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
7243 7244 7245 7246 7247 7248 7249 |
Tcl_SetObjResult(interp, Tcl_NewListObj(3, idata));
}
return TCL_OK;
}
static int
TestNREUnwind(
| | | | 7243 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 7262 7263 7264 7265 7266 7267 7268 7269 7270 7271 7272 7273 7274 7275 |
Tcl_SetObjResult(interp, Tcl_NewListObj(3, idata));
}
return TCL_OK;
}
static int
TestNREUnwind(
TCL_UNUSED(void *),
Tcl_Interp *interp,
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
/*
* Insure that callbacks effectively run at the proper level during the
* unwinding of the NRE stack.
*/
Tcl_NRAddCallback(interp, NREUnwind_callback, INT2PTR(-1), INT2PTR(-1),
INT2PTR(-1), NULL);
return TCL_OK;
}
static int
TestNRELevels(
TCL_UNUSED(void *),
Tcl_Interp *interp,
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
Interp *iPtr = (Interp *) interp;
static ptrdiff_t *refDepth = NULL;
ptrdiff_t depth;
|
| ︙ | ︙ | |||
7317 7318 7319 7320 7321 7322 7323 | * None. * *---------------------------------------------------------------------- */ static int TestconcatobjCmd( | | | 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 7328 7329 7330 7331 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestconcatobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
Tcl_Obj *list1Ptr, *list2Ptr, *emptyPtr, *concatPtr, *tmpPtr;
int result = TCL_OK, len;
Tcl_Obj *objv[3];
|
| ︙ | ︙ | |||
7613 7614 7615 7616 7617 7618 7619 | * None. * *---------------------------------------------------------------------- */ static int TestgetencpathObjCmd( | | | 7613 7614 7615 7616 7617 7618 7619 7620 7621 7622 7623 7624 7625 7626 7627 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetencpathObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
|
| ︙ | ︙ | |||
7646 7647 7648 7649 7650 7651 7652 | * None. * *---------------------------------------------------------------------- */ static int TestsetencpathObjCmd( | | | 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 7656 7657 7658 7659 7660 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsetencpathObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "defaultDir");
return TCL_ERROR;
|
| ︙ | ︙ | |||
7680 7681 7682 7683 7684 7685 7686 | * None. * *---------------------------------------------------------------------- */ static int TestparseargsCmd( | | | 7680 7681 7682 7683 7684 7685 7686 7687 7688 7689 7690 7691 7692 7693 7694 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparseargsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Arguments. */
{
static int foo = 0;
int count = objc;
Tcl_Obj **remObjv, *result[3];
|
| ︙ | ︙ | |||
7919 7920 7921 7922 7923 7924 7925 |
return TCL_OK;
}
return TCL_CONTINUE;
}
static int
TestInterpResolverCmd(
| | | | 7919 7920 7921 7922 7923 7924 7925 7926 7927 7928 7929 7930 7931 7932 7933 7934 7935 7936 7937 7938 7939 7940 7941 7942 7943 7944 7945 7946 7947 7948 7949 |
return TCL_OK;
}
return TCL_CONTINUE;
}
static int
TestInterpResolverCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
static const char *const table[] = {
"down", "up", NULL
};
int idx;
#define RESOLVER_KEY "testInterpResolver"
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "up|down ?interp?");
return TCL_ERROR;
}
if (objc == 3) {
interp = Tcl_GetChild(interp, Tcl_GetString(objv[2]));
if (interp == NULL) {
Tcl_AppendResult(interp, "provided interpreter not found", NULL);
return TCL_ERROR;
}
}
if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT,
&idx) != TCL_OK) {
|
| ︙ | ︙ |
Changes to generic/tclTestObj.c.
| ︙ | ︙ | |||
137 138 139 140 141 142 143 | * type. * *---------------------------------------------------------------------- */ static int TestbignumobjCmd( | | | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 |
* type.
*
*----------------------------------------------------------------------
*/
static int
TestbignumobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
{
const char *const subcmds[] = {
"set", "get", "mult10", "div10", "iseven", "radixsize", NULL
};
|
| ︙ | ︙ | |||
336 337 338 339 340 341 342 | * have boolean type. * *---------------------------------------------------------------------- */ static int TestbooleanobjCmd( | | | 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 |
* have boolean type.
*
*----------------------------------------------------------------------
*/
static int
TestbooleanobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int varIndex, boolValue;
const char *index, *subCmd;
Tcl_Obj **varPtr;
|
| ︙ | ︙ | |||
436 437 438 439 440 441 442 | * have double type. * *---------------------------------------------------------------------- */ static int TestdoubleobjCmd( | | | 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 |
* have double type.
*
*----------------------------------------------------------------------
*/
static int
TestdoubleobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int varIndex;
double doubleValue;
const char *index, *subCmd, *string;
|
| ︙ | ︙ | |||
554 555 556 557 558 559 560 | * have int type. * *---------------------------------------------------------------------- */ static int TestindexobjCmd( | | | 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 |
* have int type.
*
*----------------------------------------------------------------------
*/
static int
TestindexobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int allowAbbrev, index, index2, setError, i, result;
const char **argv;
static const char *const tablePtr[] = {"a", "b", "check", NULL};
|
| ︙ | ︙ | |||
615 616 617 618 619 620 621 |
argv = (const char **)Tcl_Alloc((objc-3) * sizeof(char *));
for (i = 4; i < objc; i++) {
argv[i-4] = Tcl_GetString(objv[i]);
}
argv[objc-4] = NULL;
result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
| | | 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 |
argv = (const char **)Tcl_Alloc((objc-3) * sizeof(char *));
for (i = 4; i < objc; i++) {
argv[i-4] = Tcl_GetString(objv[i]);
}
argv[objc-4] = NULL;
result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
argv, "token", TCL_INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT),
&index);
Tcl_Free((void *)argv);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
|
| ︙ | ︙ | |||
644 645 646 647 648 649 650 | * have int type. * *---------------------------------------------------------------------- */ static int TestintobjCmd( | | | 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 |
* have int type.
*
*----------------------------------------------------------------------
*/
static int
TestintobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int intValue, varIndex, i;
Tcl_WideInt wideValue;
const char *index, *subCmd, *string;
|
| ︙ | ︙ | |||
848 849 850 851 852 853 854 | * Creates, manipulates and frees list objects. * *----------------------------------------------------------------------------- */ static int TestlistobjCmd( | | | 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 |
* Creates, manipulates and frees list objects.
*
*-----------------------------------------------------------------------------
*/
static int
TestlistobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
/* Subcommands supported by this command */
const char* subcommands[] = {
"set",
|
| ︙ | ︙ | |||
945 946 947 948 949 950 951 | * Creates and frees objects. * *---------------------------------------------------------------------- */ static int TestobjCmd( | | | 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 |
* Creates and frees objects.
*
*----------------------------------------------------------------------
*/
static int
TestobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int varIndex, destIndex, i;
const char *index, *subCmd, *string;
const Tcl_ObjType *targetType;
|
| ︙ | ︙ | |||
1157 1158 1159 1160 1161 1162 1163 | * have string type. * *---------------------------------------------------------------------- */ static int TeststringobjCmd( | | | 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 |
* have string type.
*
*----------------------------------------------------------------------
*/
static int
TeststringobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_UniChar *unicode;
int varIndex, option, i, length;
#define MAX_STRINGS 11
|
| ︙ | ︙ |
Changes to generic/tclTestProcBodyObj.c.
| ︙ | ︙ | |||
224 225 226 227 228 229 230 | * Leaves an error message in the interp's result on error. * *---------------------------------------------------------------------- */ static int ProcBodyTestProcObjCmd( | | | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 |
* Leaves an error message in the interp's result on error.
*
*----------------------------------------------------------------------
*/
static int
ProcBodyTestProcObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* the current interpreter */
int objc, /* argument count */
Tcl_Obj *const objv[]) /* arguments */
{
const char *fullName;
Tcl_Command procCmd;
Command *cmdPtr;
|
| ︙ | ︙ | |||
323 324 325 326 327 328 329 | * Returns a standard Tcl code. * *---------------------------------------------------------------------- */ static int ProcBodyTestCheckObjCmd( | | | 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 |
* Returns a standard Tcl code.
*
*----------------------------------------------------------------------
*/
static int
ProcBodyTestCheckObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* the current interpreter */
int objc, /* argument count */
Tcl_Obj *const objv[]) /* arguments */
{
const char *version;
if (objc != 1) {
|
| ︙ | ︙ |
Changes to generic/tclThreadTest.c.
| ︙ | ︙ | |||
201 202 203 204 205 206 207 | * See the user documentation. * *---------------------------------------------------------------------- */ static int ThreadObjCmd( | | | 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int option;
static const char *const threadOptions[] = {
|
| ︙ | ︙ | |||
1101 1102 1103 1104 1105 1106 1107 |
*
*------------------------------------------------------------------------
*/
static int
ThreadDeleteEvent(
Tcl_Event *eventPtr, /* Really ThreadEvent */
| | | 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 |
*
*------------------------------------------------------------------------
*/
static int
ThreadDeleteEvent(
Tcl_Event *eventPtr, /* Really ThreadEvent */
TCL_UNUSED(void *))
{
if (eventPtr->proc == ThreadEventProc) {
Tcl_Free(((ThreadEvent *) eventPtr)->script);
return 1;
}
/*
|
| ︙ | ︙ |
Changes to generic/tclTrace.c.
| ︙ | ︙ | |||
179 180 181 182 183 184 185 | * Side effects: * See the user documentation. *---------------------------------------------------------------------- */ int Tcl_TraceObjCmd( | | | 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 |
* Side effects:
* See the user documentation.
*----------------------------------------------------------------------
*/
int
Tcl_TraceObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int optionIndex;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
const char *name;
|
| ︙ | ︙ |
Changes to generic/tclUtil.c.
| ︙ | ︙ | |||
3513 3514 3515 3516 3517 3518 3519 |
TclFreeIntRep(objPtr);
if (t1 && t2) {
/* We have both integer values */
if ((t1 == TCL_NUMBER_INT) && (t2 == TCL_NUMBER_INT)) {
/* Both are wide, do wide-integer math */
if (*opPtr == '-') {
| | | 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 |
TclFreeIntRep(objPtr);
if (t1 && t2) {
/* We have both integer values */
if ((t1 == TCL_NUMBER_INT) && (t2 == TCL_NUMBER_INT)) {
/* Both are wide, do wide-integer math */
if (*opPtr == '-') {
if (w2 == WIDE_MIN) {
goto extreme;
}
w2 = -w2;
}
if ((w1 ^ w2) < 0) {
/* Different signs, sum cannot overflow */
|
| ︙ | ︙ | |||
3535 3536 3537 3538 3539 3540 3541 |
} else {
if (w1 > WIDE_MIN - w2) {
offset = w1 + w2;
} else {
offset = WIDE_MIN;
}
}
| < < < < < < < > | > > > > > | 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 |
} else {
if (w1 > WIDE_MIN - w2) {
offset = w1 + w2;
} else {
offset = WIDE_MIN;
}
}
} else {
/*
* At least one is big, do bignum math. Little reason to
* value performance here. Re-use code. Parse has verified
* objPtr is an expression. Compute it.
*/
Tcl_Obj *sum;
extreme:
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) {
/* sum holds an integer in the signed wide range */
offset = *(Tcl_WideInt *)cd;
} else {
/* sum holds an integer outside the signed wide range */
|
| ︙ | ︙ |
Changes to library/clock.tcl.
| ︙ | ︙ | |||
3300 3301 3302 3303 3304 3305 3306 |
variable DataDir
variable TZData
if { [info exists TZData($fileName)] } {
return
}
| | | 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 |
variable DataDir
variable TZData
if { [info exists TZData($fileName)] } {
return
}
# 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.
if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
return -code error \
-errorcode [list CLOCK badTimeZone $:fileName] \
"time zone \":$fileName\" not valid"
|
| ︙ | ︙ | |||
3340 3341 3342 3343 3344 3345 3346 |
# TZData(:fileName) contains the time zone data
#
#----------------------------------------------------------------------
proc ::tcl::clock::LoadZoneinfoFile { fileName } {
variable ZoneinfoPaths
| | | 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 |
# TZData(:fileName) contains the time zone data
#
#----------------------------------------------------------------------
proc ::tcl::clock::LoadZoneinfoFile { fileName } {
variable ZoneinfoPaths
# 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.
if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
return -code error \
-errorcode [list CLOCK badTimeZone $:fileName] \
"time zone \":$fileName\" not valid"
|
| ︙ | ︙ |
Changes to library/http/http.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # http.tcl -- # # Client-side HTTP for GET, POST, and HEAD commands. These routines can # be used in untrusted code that uses the Safesock security policy. # These procedures use a callback interface to avoid using vwait, which # is not defined in the safe base. # # 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.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# http.tcl --
#
# Client-side HTTP for GET, POST, and HEAD commands. These routines can
# be used in untrusted code that uses the Safesock security policy.
# These procedures use a callback interface to avoid using vwait, which
# is not defined in the safe base.
#
# 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.6-
# Keep this in sync with pkgIndex.tcl and with the install directories in
# Makefiles
package provide http 2.9.5
namespace eval http {
# Allow resourcing to not clobber existing data
variable http
if {![info exists http]} {
array set http {
|
| ︙ | ︙ | |||
540 541 542 543 544 545 546 |
upvar 0 $token state
if {[info exists state(socketinfo)]} {
set connId $state(socketinfo)
}
} else {
set map [array get socketMapping]
set ndx [lsearch -exact $map $s]
| | | 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 |
upvar 0 $token state
if {[info exists state(socketinfo)]} {
set connId $state(socketinfo)
}
} else {
set map [array get socketMapping]
set ndx [lsearch -exact $map $s]
if {$ndx >= 0} {
incr ndx -1
set connId [lindex $map $ndx]
}
}
if { ($connId ne {})
&& [info exists socketMapping($connId)]
&& ($socketMapping($connId) eq $s)
|
| ︙ | ︙ | |||
978 979 980 981 982 983 984 985 986 987 988 989 990 991 |
# There is a small risk of a race against server timeout.
set state(-pipeline) 0
}
} else {
# It's a GET or HEAD.
set state(-pipeline) $http(-pipeline)
}
# 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
# request to leave the channel open AFTER completion of this call.
# - In fact, we try to use an existing channel only if -keepalive 1 -- this
# means that at most one channel is left open for each value of
| > > > > > > > > > > > > | 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 |
# There is a small risk of a race against server timeout.
set state(-pipeline) 0
}
} else {
# It's a GET or HEAD.
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
# request to leave the channel open AFTER completion of this call.
# - In fact, we try to use an existing channel only if -keepalive 1 -- this
# means that at most one channel is left open for each value of
|
| ︙ | ︙ | |||
1351 1352 1353 1354 1355 1356 1357 |
# work properly.
fconfigure $state(-querychannel) -blocking 1 -translation binary
set contDone 0
}
if {[info exists state(-method)] && ($state(-method) ne "")} {
set how $state(-method)
}
| < < < < < | 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 |
# work properly.
fconfigure $state(-querychannel) -blocking 1 -translation binary
set contDone 0
}
if {[info exists state(-method)] && ($state(-method) ne "")} {
set how $state(-method)
}
set accept_types_seen 0
Log ^B$tk begin sending request - token $token
if {[catch {
set state(method) $how
puts $sock "$how $srvurl HTTP/$state(-protocol)"
|
| ︙ | ︙ | |||
1378 1379 1380 1381 1382 1383 1384 |
set state(host) $host
puts $sock "Host: $host"
} else {
set state(host) $host
puts $sock "Host: $host:$port"
}
puts $sock "User-Agent: $http(-useragent)"
| | > > > > > > | | > > | 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 |
set state(host) $host
puts $sock "Host: $host"
} else {
set state(host) $host
puts $sock "Host: $host:$port"
}
puts $sock "User-Agent: $http(-useragent)"
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"
}
if {($state(-protocol) > 1.0) && !$state(-keepalive)} {
puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1
}
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) {
set value [string map [list \n "" \r ""] $value]
set key [string map {" " -} [string trim $key]]
if {[string equal -nocase $key "host"]} {
continue
|
| ︙ | ︙ | |||
1664 1665 1666 1667 1668 1669 1670 |
#Log ---- $state(socketinfo) >> conn to $token for HTTP response
lassign [fconfigure $sock -translation] trRead trWrite
fconfigure $sock -translation [list auto $trWrite] \
-buffersize $state(-blocksize)
Log ^D$tk begin receiving response - token $token
coroutine ${token}EventCoroutine http::Event $sock $token
| > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 |
#Log ---- $state(socketinfo) >> conn to $token for HTTP response
lassign [fconfigure $sock -translation] trRead trWrite
fconfigure $sock -translation [list auto $trWrite] \
-buffersize $state(-blocksize)
Log ^D$tk begin receiving response - token $token
coroutine ${token}EventCoroutine http::Event $sock $token
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
# command KeepSocket.
# - If another request has a pipelined write scheduled for $token's socket,
# and if the socket is ready to accept it, connect the write and update
|
| ︙ | ︙ | |||
2730 2731 2732 2733 2734 2735 2736 |
# list is an acceptable value. According to
# https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection
# any comma-separated list implies keep-alive, but I
# don't see this in the RFC so we'll play safe and
# scan any list for "close".
if {$tmpHeader in {close keep-alive}} {
# The common cases, continue.
| | | | > | 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 |
# list is an acceptable value. According to
# https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection
# any comma-separated list implies keep-alive, but I
# don't see this in the RFC so we'll play safe and
# scan any list for "close".
if {$tmpHeader in {close keep-alive}} {
# The common cases, continue.
} elseif {[string first , $tmpHeader] < 0} {
# Not a comma-separated list, not "close",
# therefore "keep-alive".
set tmpHeader keep-alive
} else {
set tmpResult keep-alive
set tmpCsl [split $tmpHeader ,]
# Optional whitespace either side of separator.
foreach el $tmpCsl {
if {[string trim $el] eq {close}} {
set tmpResult close
break
}
}
set tmpHeader $tmpResult
}
set state(connection) $tmpHeader
}
set-cookie {
if {$http(-cookiejar) ne ""} {
ParseCookie $token [string trim $value]
}
|
| ︙ | ︙ |
Changes to library/http/pkgIndex.tcl.
1 |
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
| | | 1 2 |
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
package ifneeded http 2.9.5 [list tclPkgSetup $dir http 2.9.5 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
|
Changes to library/init.tcl.
| ︙ | ︙ | |||
241 242 243 244 245 246 247 |
if {$last + [string length $tail] != [string length $errInfo]} {
# Very likely cannot happen
return -options $opts $msg
}
set errInfo [string range $errInfo 0 $last-1]
set tail "\"$cinfo\""
set last [string last $tail $errInfo]
| | | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 |
if {$last + [string length $tail] != [string length $errInfo]} {
# Very likely cannot happen
return -options $opts $msg
}
set errInfo [string range $errInfo 0 $last-1]
set tail "\"$cinfo\""
set last [string last $tail $errInfo]
if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} {
return -code error -errorcode $errCode \
-errorinfo $errInfo $msg
}
set errInfo [string range $errInfo 0 $last-1]
set tail "\n invoked from within\n"
set last [string last $tail $errInfo]
if {$last + [string length $tail] == [string length $errInfo]} {
|
| ︙ | ︙ | |||
738 739 740 741 742 743 744 |
if {[file tail $s] ni {. ..}} {
return -code error "error $action \"$src\" to\
\"$dest\": file already exists"
}
}
}
} else {
| | | 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 |
if {[file tail $s] ni {. ..}} {
return -code error "error $action \"$src\" to\
\"$dest\": file already exists"
}
}
}
} else {
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]} {
return -code error "error $action \"$src\" to\
\"$dest\": trying to rename a volume or move a directory\
into itself"
}
|
| ︙ | ︙ |
Changes to library/install.tcl.
| ︙ | ︙ | |||
100 101 102 103 104 105 106 |
}
if {[regexp "if.*package.*vsatisfies.*package.*provide.*return" $thisline]} {
if {$trace} { puts "[file dirname $pkgidxfile] Ignoring $thisline" }
set thisline {} ; continue
}
if {![regexp "package.*ifneeded" $thisline]} {
# This package index contains arbitrary code
| | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
}
if {[regexp "if.*package.*vsatisfies.*package.*provide.*return" $thisline]} {
if {$trace} { puts "[file dirname $pkgidxfile] Ignoring $thisline" }
set thisline {} ; continue
}
if {![regexp "package.*ifneeded" $thisline]} {
# This package index contains arbitrary code
# 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]}
}
append buffer $thisline \n
set thisline {}
}
|
| ︙ | ︙ |
Changes to library/manifest.txt.
1 2 3 4 5 6 7 |
###
# Package manifest for all Tcl packages included in the /library file system
###
apply {{dir} {
set ::test [info script]
set isafe [interp issafe]
foreach {safe package version file} {
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
###
# Package manifest for all Tcl packages included in the /library file system
###
apply {{dir} {
set ::test [info script]
set isafe [interp issafe]
foreach {safe package version file} {
0 http 2.9.5 {http http.tcl}
1 msgcat 1.7.1 {msgcat msgcat.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}
0 platform::shell 1.1.4 {platform shell.tcl}
1 tcltest 2.5.3 {tcltest tcltest.tcl}
} {
if {$isafe && !$safe} continue
|
| ︙ | ︙ |
Changes to library/opt/optparse.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # optparse.tcl -- # # (private) Option parsing package # Primarily used internally by the safe:: code. # # WARNING: This code will go away in a future release # of Tcl. It is NOT supported and you should not rely # on it. If your code does rely on this package you # may directly incorporate this code into your application. package require Tcl 8.5- # When this version number changes, update the pkgIndex.tcl file # and the install directory in the Makefiles. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# optparse.tcl --
#
# (private) Option parsing package
# Primarily used internally by the safe:: code.
#
# WARNING: This code will go away in a future release
# of Tcl. It is NOT supported and you should not rely
# on it. If your code does rely on this package you
# may directly incorporate this code into your application.
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.8
namespace eval ::tcl {
# Exported APIs
namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
OptProc OptProcArgGiven OptParse \
Lempty Lget \
|
| ︙ | ︙ | |||
40 41 42 43 44 45 46 |
OptProc OptParseTest {
{subcommand -choice {save print} "sub command"}
{arg1 3 "some number"}
{-aflag}
{-intflag 7}
{-weirdflag "help string"}
{-noStatics "Not ok to load static packages"}
| | | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
OptProc OptParseTest {
{subcommand -choice {save print} "sub command"}
{arg1 3 "some number"}
{-aflag}
{-intflag 7}
{-weirdflag "help string"}
{-noStatics "Not ok to load static packages"}
{-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"}
{-intval 7 "An integer"}
{-scale -float 1.0 "Scale factor"}
{-zoom 1.0 "Zoom factor"}
{-arbitrary foobar "Arbitrary string"}
|
| ︙ | ︙ |
Changes to library/opt/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 |
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" 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.
if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" 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.
if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
package ifneeded opt 0.4.8 [list source [file join $dir optparse.tcl]]
|
Changes to library/package.tcl.
| ︙ | ︙ | |||
233 234 235 236 237 238 239 | } } $c eval [list set ::tcl::dir $dir] $c eval [list set ::tcl::file $file] $c eval [list set ::tcl::direct $direct] | | | 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 |
}
}
$c eval [list set ::tcl::dir $dir]
$c eval [list set ::tcl::file $file]
$c eval [list set ::tcl::direct $direct]
# Download needed procedures into the child because we've just deleted
# the unknown procedure. This doesn't handle procedures with default
# arguments.
foreach p {::tcl::Pkg::CompareExtension} {
$c eval [list namespace eval [namespace qualifiers $p] {}]
$c eval [list proc $p [info args $p] [info body $p]]
}
|
| ︙ | ︙ | |||
475 476 477 478 479 480 481 |
# Make sure we only scan each directory one time.
if {[info exists tclSeenPath($dir)]} {
set use_path [lrange $use_path 0 end-1]
continue
}
set tclSeenPath($dir) 1
| < | > | > > > | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 |
# Make sure we only scan each directory one time.
if {[info exists tclSeenPath($dir)]} {
set use_path [lrange $use_path 0 end-1]
continue
}
set tclSeenPath($dir) 1
# 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] {
set dir [file dirname $file]
if {![info exists procdDirs($dir)]} {
try {
::tcl::Pkg::source $file
|
| ︙ | ︙ | |||
589 590 591 592 593 594 595 596 597 598 599 600 601 602 |
if {[info exists tclSeenPath($dir)]} {
set use_path [lrange $use_path 0 end-1]
continue
}
set tclSeenPath($dir) 1
# get the pkgIndex files out of the subdirectories
foreach file [glob -directory $dir -join -nocomplain \
* Resources Scripts pkgIndex.tcl] {
set dir [file dirname $file]
if {![info exists procdDirs($dir)]} {
try {
::tcl::Pkg::source $file
} trap {POSIX EACCES} {} {
| > | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 |
if {[info exists tclSeenPath($dir)]} {
set use_path [lrange $use_path 0 end-1]
continue
}
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]
if {![info exists procdDirs($dir)]} {
try {
::tcl::Pkg::source $file
} trap {POSIX EACCES} {} {
|
| ︙ | ︙ |
Changes to library/safe.tcl.
1 2 3 4 | # safe.tcl -- # # This file provide a safe loading/sourcing mechanism for safe interpreters. # It implements a virtual path mecanism to hide the real pathnames from the | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# safe.tcl --
#
# This file provide a safe loading/sourcing mechanism for safe interpreters.
# It implements a virtual path mecanism to hide the real pathnames from the
# 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.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# The implementation is based on namespaces. These naming conventions are
# followed:
# Private procs starts with uppercase.
# Public procs are exported and starts with lowercase
#
# Needed utilities package
package require opt 0.4.8
# Create the safe namespace
namespace eval ::safe {
# Exported API:
namespace export interpCreate interpInit interpConfigure interpDelete \
interpAddToAccessPath interpFindInAccessPath setLogCmd
}
|
| ︙ | ︙ | |||
75 76 77 78 79 80 81 |
# API entry points that needs argument parsing :
#
####
# Interface/entry point function and front end for "Create"
proc ::safe::interpCreate {args} {
set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
| > | | | > | | | | | | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 |
# API entry points that needs argument parsing :
#
####
# Interface/entry point function and front end for "Create"
proc ::safe::interpCreate {args} {
set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
RejectExcessColons $child
InterpCreate $child $accessPath \
[InterpStatics] [InterpNested] $deleteHook
}
proc ::safe::interpInit {args} {
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
if {![::interp exists $child]} {
return -code error "\"$child\" is not an interpreter"
}
RejectExcessColons $child
InterpInit $child $accessPath \
[InterpStatics] [InterpNested] $deleteHook
}
# 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 \
"\"$child\" is not an interpreter managed by ::safe::"
}
}
# Interface/entry point function and front end for "Configure". This code
# is awfully pedestrian because it would need more coupling and support
# between the way we store the configuration values in safe::interp's and
# the Opt package. Obviously we would like an OptConfigure to avoid
|
| ︙ | ︙ | |||
115 116 117 118 119 120 121 |
# So this will be hopefully written and some integrated with opt1.0
# (hopefully for tcl9.0 ?)
proc ::safe::interpConfigure {args} {
switch [llength $args] {
1 {
# If we have exactly 1 argument the semantic is to return all
# the current configuration. We still call OptKeyParse though
| | | | | | | | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 |
# So this will be hopefully written and some integrated with opt1.0
# (hopefully for tcl9.0 ?)
proc ::safe::interpConfigure {args} {
switch [llength $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 "child" is our given argument because it also
# checks for the "-help" option.
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
CheckInterp $child
namespace upvar ::safe [VarName $child] state
return [join [list \
[list -accessPath $state(access_path)] \
[list -statics $state(staticsok)] \
[list -nested $state(nestedok)] \
[list -deleteHook $state(cleanupHook)]]]
}
2 {
# If we have exactly 2 arguments the semantic is a "configure
# get"
lassign $args child arg
# get the flag sub program (we 'know' about Opt's internal
# representation of data)
set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]
set hits [::tcl::OptHits desc $arg]
if {$hits > 1} {
return -code error [::tcl::OptAmbigous $desc $arg]
} elseif {$hits == 0} {
return -code error [::tcl::OptFlagUsage $desc $arg]
}
CheckInterp $child
namespace upvar ::safe [VarName $child] state
set item [::tcl::OptCurDesc $desc]
set name [::tcl::OptName $item]
switch -exact -- $name {
-accessPath {
return [list -accessPath $state(access_path)]
}
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 |
}
}
}
default {
# Otherwise we want to parse the arguments like init and
# create did
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
| | | | | | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 |
}
}
}
default {
# Otherwise we want to parse the arguments like init and
# create did
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
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 0
set accessPath $state(access_path)
} else {
set doreset 1
}
if {
![::tcl::OptProcArgGiven -statics]
&& ![::tcl::OptProcArgGiven -noStatics]
} then {
set statics $state(staticsok)
} else {
|
| ︙ | ︙ | |||
213 214 215 216 217 218 219 |
} else {
set nested $state(nestedok)
}
if {![::tcl::OptProcArgGiven -deleteHook]} {
set deleteHook $state(cleanupHook)
}
# we can now reconfigure :
| | | | | | | > > > > > > > > > > > > > > > > > > > | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > | > > > > | > > | | | > | > | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 |
} else {
set nested $state(nestedok)
}
if {![::tcl::OptProcArgGiven -deleteHook]} {
set deleteHook $state(cleanupHook)
}
# we can now reconfigure :
InterpSetConfig $child $accessPath $statics $nested $deleteHook
# auto_reset the child (to completly synch the new access_path)
if {$doreset} {
if {[catch {::interp eval $child {auto_reset}} msg]} {
Log $child "auto_reset failed: $msg"
} else {
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
}
}
}
####
#
# Functions that actually implements the exported APIs
#
####
#
# safe::InterpCreate : doing the real job
#
# This procedure creates a safe interpreter and initializes it with the safe
# base aliases.
# 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 child name.
#
# Optional Arguments :
# + child name : if empty, generated name will be used
# + access_path: path list controlling where load/source can occur,
# 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)
# if 1 : multiple levels are ok.
# use the full name and no indent so auto_mkIndex can find us
proc ::safe::InterpCreate {
child
access_path
staticsok
nestedok
deletehook
} {
# 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 child name
set child [::interp create -safe]
}
Log $child "Created" NOTICE
# Initialize it. (returns child name)
InterpInit $child $access_path $staticsok $nestedok $deletehook
}
#
# InterpSetConfig (was setAccessPath) :
# 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 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 {child access_path staticsok nestedok deletehook} {
global auto_path
# determine and store the access path if empty
if {$access_path eq ""} {
set access_path $auto_path
# 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 < 0} {
# not found, add it.
set access_path [linsert $access_path 0 [info library]]
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 $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 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 $child "Setting accessPath=($access_path) staticsok=$staticsok\
nestedok=$nestedok deletehook=($deletehook)" NOTICE
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
# child has to be defered until the necessary commands are present for
# setup.
set norm_access_path {}
set child_access_path {}
set map_access_path {}
set remap_access_path {}
set child_tm_path {}
set i 0
foreach dir $access_path {
set token [PathToken $i]
lappend child_access_path $token
lappend map_access_path $token $dir
lappend remap_access_path $dir $token
lappend norm_access_path [file normalize $dir]
incr i
}
set morepaths [::tcl::tm::list]
set firstpass 1
while {[llength $morepaths]} {
set addpaths $morepaths
set morepaths {}
foreach dir $addpaths {
# 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 child_access_path $token
lappend map_access_path $token $dir
lappend remap_access_path $dir $token
lappend norm_access_path [file normalize $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 $token
}
incr i
# [Bug 2854929]
# Recursively find deeper paths which may contain
# modules. Required to handle modules with names like
# 'platform::shell', which translate into
# 'platform/shell-X.tm', i.e arbitrarily deep
# 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,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 $child
return
}
#
#
# FindInAccessPath:
# Search for a real directory and returns its virtual Id (including the
# "$")
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"
}
return [dict get $state(access_path,remap) $path]
}
#
# addToAccessPath:
# add (if needed) a real directory to access path and return its
# virtual token (including the "$").
proc ::safe::interpAddToAccessPath {child path} {
# first check if the directory is already in there
# (inlined interpFindInAccessPath).
CheckInterp $child
namespace upvar ::safe [VarName $child] state
if {[dict exists $state(access_path,remap) $path]} {
return [dict get $state(access_path,remap) $path]
}
# new one, add it:
set token [PathToken [llength $state(access_path)]]
lappend state(access_path) $path
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 $child
return $token
}
# This procedure applies the initializations to an already existing
# interpreter. It is useful when you want to install the safe base aliases
# into a preexisting safe interpreter.
proc ::safe::InterpInit {
child
access_path
staticsok
nestedok
deletehook
} {
# Configure will generate an access_path when access_path is empty.
InterpSetConfig $child $access_path $staticsok $nestedok $deletehook
# NB we need to add [namespace current], aliases are always absolute
# paths.
# 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 child.
foreach {command alias} {
source AliasSource
load AliasLoad
exit interpDelete
glob AliasGlob
} {
::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 $child $command {} interp invokehidden $child $command
}
# This alias lets the child have access to a subset of the 'file'
# command functionality.
foreach subcommand {dirname extension rootname tail} {
::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 $child ::tcl::encoding::system {} \
::safe::AliasEncodingSystem $child
# Subcommands of info
::interp alias $child ::tcl::info::nameofexecutable {} \
::safe::AliasExeName $child
# The allowed child variables already have been set by Tcl_MakeSafe(3)
# Source init.tcl and tm.tcl into the child, to get auto_load and
# other procedures defined:
if {[catch {::interp eval $child {
source [file join $tcl_library init.tcl]
}} msg opt]} {
Log $child "can't source init.tcl ($msg)"
return -options $opt "can't source init.tcl into child $child ($msg)"
}
if {[catch {::interp eval $child {
source [file join $tcl_library tm.tcl]
}} msg opt]} {
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 [VarName $child] state
if {[llength $state(tm_path_child)] > 0} {
::interp eval $child [list \
::tcl::tm::add {*}[lreverse $state(tm_path_child)]]
}
return $child
}
# Add (only if needed, avoid duplicates) 1 level of sub directories to an
# existing path list. Also removes non directories from the returned
# list.
proc ::safe::AddSubDirs {pathList} {
set res {}
|
| ︙ | ︙ | |||
533 534 535 536 537 538 539 |
}
}
}
}
return $res
}
| | | > > > | | > | > > > > > > > > > > > | | | | | | | | 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 |
}
}
}
}
return $res
}
# 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 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
if {[info exists state(cleanupHook)]} {
set hook $state(cleanupHook)
if {[llength $hook]} {
# remove the hook now, otherwise if the hook calls us somehow,
# we'll loop
unset state(cleanupHook)
try {
{*}$hook $child
} on error err {
Log $child "Delete hook error ($err)"
}
}
}
# Discard the global array of state associated with the child, and
# delete the interpreter.
if {[info exists state]} {
unset state
}
# if we have been called twice, the interp might have been deleted
# already
if {[::interp exists $child]} {
::interp delete $child
Log $child "Deleted" NOTICE
}
return
}
# Set (or get) the logging mecanism
|
| ︙ | ︙ | |||
596 597 598 599 600 601 602 |
if {$Log eq ""} {
# Disable logging completely. Calls to it will be compiled out
# of all users.
proc ::safe::Log {args} {}
} else {
# Activate logging, define proper command.
| | | | | | | | | | | | | | | | | | | 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 |
if {$Log eq ""} {
# Disable logging completely. Calls to it will be compiled out
# of all users.
proc ::safe::Log {args} {}
} else {
# Activate logging, define proper command.
proc ::safe::Log {child msg {type ERROR}} {
variable Log
{*}$Log "$type for child $child : $msg"
return
}
}
}
# ------------------- END OF PUBLIC METHODS ------------
#
# 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 {child} {
namespace upvar ::safe [VarName $child] state
set child_access_path $state(access_path,child)
::interp eval $child [list set auto_path $child_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 $child [list \
set tcl_library [lindex $child_access_path 0]]
}
# Returns the virtual token for directory number N.
proc ::safe::PathToken {n} {
# We need to have a ":" in the token string so [file join] on the
# mac won't turn it into a relative path.
return "\$p(:$n:)" ;# Form tested by case 7.2
}
#
# translate virtual path into real path
#
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... :
if {[string match "*::*" $path] || [string match "*..*" $path]} {
return -code error "invalid characters in path $path"
}
# Use a cached map instead of computed local vars and subst.
return [string map $state(access_path,map) $path]
}
# file name control (limit access to files/resources that should be a
# valid tcl source 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
# allow sourcing anything. - hobbs
if {![file exists $file]} {
# don't tell the file path
return -code error "no such file or directory"
}
if {![file readable $file]} {
# don't tell the file path
return -code error "not readable"
}
}
# AliasFileSubcommand handles selected subcommands of [file] in safe
# interpreters that are *almost* safe. In particular, it just acts to
# prevent discovery of what home directories exist.
proc ::safe::AliasFileSubcommand {child subcommand name} {
if {[string match ~* $name]} {
set name ./$name
}
tailcall ::interp invokehidden $child tcl:file:$subcommand $name
}
# AliasGlob is the target of the "glob" alias in safe interpreters.
proc ::safe::AliasGlob {child args} {
Log $child "GLOB ! $args" NOTICE
set cmd {}
set at 0
array set got {
-directory 0
-nocomplain 0
-join 0
-tails 0
|
| ︙ | ︙ | |||
706 707 708 709 710 711 712 |
}
set dir {}
set virtualdir {}
while {$at < [llength $args]} {
switch -glob -- [set opt [lindex $args $at]] {
| | > > > > < < < < < < < | | | | | > > > | | > > > > > > > | > | > | > | < > > > > | | | | | > > > > > > > > > > > > > > > > > > | | | > > > > > > > | > > | | | | | | | | | | | | | > > > | | | | | | | | | | | | | | | | | | | | > > > > > > > | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 |
}
set dir {}
set virtualdir {}
while {$at < [llength $args]} {
switch -glob -- [set opt [lindex $args $at]] {
-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
}
-directory {
if {$got($opt)} {
return -code error \
{"-directory" cannot be used with "-path"}
}
set got($opt) 1
set virtualdir [lindex $args [incr at]]
incr at
}
-* {
Log $child "Safe base rejecting glob option '$opt'"
return -code error "Safe base rejecting glob option '$opt'"
}
default {
break
}
}
if {$got(--)} break
}
# Get the real path from the virtual one and check that the path is in the
# 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 $child $virtualdir]
DirInAccessPath $child $dir
} on error msg {
Log $child $msg
if {$got(-nocomplain)} return
return -code error "permission denied"
}
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.
if {$got(-join)} {
set args [lreplace $args $at end [join [lrange $args $at end] "/"]]
}
# Process the pattern arguments. If we've done a join there is only one
# pattern argument.
set firstPattern [llength $cmd]
foreach opt [lrange $args $at end] {
if {![regexp $dirPartRE $opt -> thedir thefile]} {
set thedir .
# The *.tm search comes here.
}
# "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 $child $virtualdir] \
-types d -tails *] {
catch {
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 $child [TranslatePath $child \
[file join $virtualdir $thedir]]
} on error msg {
Log $child $msg
if {$got(-nocomplain)} continue
return -code error "permission denied"
}
lappend cmd $opt
}
Log $child "GLOB = $cmd" NOTICE
if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} {
return
}
try {
# >>>>>>>>>> HERE'S THE CALL TO SAFE INTERP GLOB <<<<<<<<<<
# - Pattern arguments added to cmd have NOT been translated from tokens.
# Only the virtualdir is translated (to dir).
# - In the pkgIndex.tcl case, there is no "*" in the pattern arguments,
# which are a list of names each with tail pkgIndex.tcl. The purpose
# of the call to glob is to remove the names for which the file does
# not exist.
set entries [::interp invokehidden $child glob {*}$cmd]
} on error msg {
# This is the only place that a call with -nocomplain and no invalid
# "dash-options" can return an error.
Log $child $msg
return -code error "script error"
}
Log $child "GLOB < $entries" NOTICE
# Translate path back to what the child should see.
set res {}
set l [string length $dir]
foreach p $entries {
if {[string equal -length $l $dir $p]} {
set p [string replace $p 0 [expr {$l-1}] $virtualdir]
}
lappend res $p
}
Log $child "GLOB > $res" NOTICE
return $res
}
# AliasSource is the target of the "source" alias in safe interpreters.
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.
if {[lindex $args 0] eq "-encoding"} {
incr argc -2
set encoding [lindex $args 1]
set at 2
if {$encoding eq "identity"} {
Log $child "attempt to use the identity encoding"
return -code error "permission denied"
}
} else {
set at 0
set encoding {}
}
if {$argc != 1} {
set msg "wrong # args: should be \"source ?-encoding E? fileName\""
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 $child $file]
} msg]} {
Log $child $msg
return -code error "permission denied"
}
# check that the path is in the access path of that child
if {[catch {
FileInAccessPath $child $realfile
} msg]} {
Log $child $msg
return -code error "permission denied"
}
# 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 $child $realfile
} 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 child so information
# doesn't leak so much. [Bug 2913625]
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
}
set contents [read $f]
close $f
::interp eval $child [list info script $file]
} msg opt]
if {$code == 0} {
set code [catch {::interp eval $child $contents} msg opt]
set replacementMsg $msg
}
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 $child $msg
return -code error $replacementMsg
}
return -code $code -options $opt $msg
}
# AliasLoad is the target of the "load" alias in safe interpreters.
proc ::safe::AliasLoad {child file args} {
set argc [llength $args]
if {$argc > 2} {
set msg "load error: too many arguments"
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 [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.
set target [lindex $args 1]
if {$target ne ""} {
# we will try to load into a sub sub interp; check that we want to
# authorize that.
if {!$state(nestedok)} {
Log $child "loading to a sub interp (nestedok)\
disabled (trying to load $package to $target)"
return -code error "permission denied (nested load)"
}
}
# Determine what kind of load is requested
if {$file eq ""} {
# static package loading
if {$package eq ""} {
set msg "load error: empty filename and no package name"
Log $child $msg
return -code error $msg
}
if {!$state(staticsok)} {
Log $child "static packages loading disabled\
(trying to load $package to $target)"
return -code error "permission denied (static package)"
}
} else {
# file loading
# get the real path from the virtual one.
try {
set file [TranslatePath $child $file]
} on error msg {
Log $child $msg
return -code error "permission denied"
}
# check the translated path
try {
FileInAccessPath $child $file
} on error msg {
Log $child $msg
return -code error "permission denied (path)"
}
}
try {
return [::interp invokehidden $child load $file $package $target]
} on error 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 (parent side recorded) child's access path.
# the security here relies on "file dirname" answering the proper
# result... needs checking ?
proc ::safe::FileInAccessPath {child file} {
namespace upvar ::safe [VarName $child] state
set access_path $state(access_path)
if {[file isdirectory $file]} {
return -code error "\"$file\": is a directory"
}
set parent [file dirname $file]
# Normalize paths for comparison since lsearch knows nothing of
# potential pathname anomalies.
set norm_parent [file normalize $parent]
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 {child dir} {
namespace upvar ::safe [VarName $child] state
set access_path $state(access_path)
if {[file isfile $dir]} {
return -code error "\"$dir\": is a file"
}
# Normalize paths for comparison since lsearch knows nothing of
# potential pathname anomalies.
set norm_dir [file normalize $dir]
namespace upvar ::safe [VarName $child] state
if {$norm_dir ni $state(access_path,norm)} {
return -code error "\"$dir\": not in access_path"
}
}
# This procedure is used to report an attempt to use an unsafe member of an
# ensemble command.
proc ::safe::BadSubcommand {child command subcommand args} {
set msg "not allowed to invoke subcommand $subcommand of $command"
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 {child args} {
try {
# 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 $child $msg
return -options $options $msg
}
tailcall ::interp invokehidden $child tcl:encoding:system
}
# Various minor hiding of platform features. [Bug 2913625]
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 {} {
####
#
# Setup the arguments parsing
#
####
# Share the descriptions
set temp [::tcl::OptKeyRegister {
{-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"}
{-nested false "nested loading"}
{-deleteHook -script {} "delete hook"}
}]
# create case (child is optional)
::tcl::OptKeyRegister {
{?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 (child is needed)
::tcl::OptKeyRegister {
{child -name {} "name of the child"}
} ::safe::interpIC
# adding the flags sub programs to the command program (relying on Opt's
# internal implementation details)
lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp)
# temp not needed anymore
|
| ︙ | ︙ | |||
1102 1103 1104 1105 1106 1107 1108 |
namespace eval ::safe {
# internal variables
# Log command, set via 'setLogCmd'. Logging is disabled when empty.
variable Log {}
| | | | | | | 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 |
namespace eval ::safe {
# internal variables
# Log command, set via 'setLogCmd'. Logging is disabled when empty.
variable Log {}
# 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 child interp called "Log" smashes
# the "Log" variable.
#
# The array's elements are:
#
# access_path : List of paths accessible to the child.
# access_path,norm : Ditto, in normalized form.
# 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_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
}
::safe::Setup
|
Changes to library/tcltest/tcltest.tcl.
| ︙ | ︙ | |||
636 637 638 639 640 641 642 |
}
}
return $valid
}
proc IsVerbose {level} {
variable Option
| | | 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 |
}
}
return $valid
}
proc IsVerbose {level} {
variable Option
return [expr {[lsearch -exact $Option(-verbose) $level] >= 0}]
}
# Default verbosity is to show bodies of failed tests
Option -verbose {body error} {
Takes any combination of the values 'p', 's', 'b', 't', 'e' and 'l'.
Test suite will display all passed tests if 'p' is specified, all
skipped tests if 's' is specified, the bodies of failed tests if
|
| ︙ | ︙ | |||
3103 3104 3105 3106 3107 3108 3109 |
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
set idx [lsearch -exact $filesMade $fullName]
| | | 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 |
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
set idx [lsearch -exact $filesMade $fullName]
if {$idx < 0} {
DebugDo 1 {
Warn "removeFile removing \"$fullName\":\n not created by makeFile"
}
} else {
set filesMade [lreplace $filesMade $idx $idx]
}
if {![file isfile $fullName]} {
|
| ︙ | ︙ | |||
3180 3181 3182 3183 3184 3185 3186 |
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"
set idx [lsearch -exact $filesMade $fullName]
set filesMade [lreplace $filesMade $idx $idx]
| | | 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 |
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"
set idx [lsearch -exact $filesMade $fullName]
set filesMade [lreplace $filesMade $idx $idx]
if {$idx < 0} {
DebugDo 1 {
Warn "removeDirectory removing \"$fullName\":\n not created\
by makeDirectory"
}
}
if {![file isdirectory $fullName]} {
DebugDo 1 {
|
| ︙ | ︙ |
Changes to library/tm.tcl.
| ︙ | ︙ | |||
208 209 210 211 212 213 214 |
}
set currentsearchpath [file join $path $pkgroot]
if {![interp issafe] && ![file exists $currentsearchpath]} {
continue
}
set strip [llength [file split $path]]
| < | < | > > | > | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 |
}
set currentsearchpath [file join $path $pkgroot]
if {![interp issafe] && ![file exists $currentsearchpath]} {
continue
}
set strip [llength [file split $path]]
# 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
# path, to get the max result out of the glob.
foreach file [glob -nocomplain -directory $currentsearchpath *.tm] {
set pkgfilename [join [lrange [file split $file] $strip end] ::]
|
| ︙ | ︙ |
Changes to macosx/Tcl.xcode/project.pbxproj.
| ︙ | ︙ | |||
1890 1891 1892 1893 1894 1895 1896 | inputPaths = ( ); name = "Run Testsuite"; outputPaths = ( ); runOnlyForDeploymentPostprocessing = 0; shellPath = /bin/bash; | | | 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 |
inputPaths = (
);
name = "Run Testsuite";
outputPaths = (
);
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.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 */ = {
isa = PBXShellScriptBuildPhase;
buildActionMask = 2147483647;
files = (
);
|
| ︙ | ︙ |
Changes to macosx/Tcl.xcodeproj/project.pbxproj.
| ︙ | ︙ | |||
1890 1891 1892 1893 1894 1895 1896 | inputPaths = ( ); name = "Run Testsuite"; outputPaths = ( ); runOnlyForDeploymentPostprocessing = 0; shellPath = /bin/bash; | | | 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 |
inputPaths = (
);
name = "Run Testsuite";
outputPaths = (
);
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.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 */ = {
isa = PBXShellScriptBuildPhase;
buildActionMask = 2147483647;
files = (
);
|
| ︙ | ︙ |
Changes to pkgs/README.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | All files of the package need to be contained in (subdirs of ...) a single subdirectory of the "pkgs" directrory. In that subdirectory of "pkgs" there must be an executable file named "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 | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
All files of the package need to be contained in (subdirs of ...) a
single subdirectory of the "pkgs" directrory.
In that subdirectory of "pkgs" there must be an executable file named
"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 top unix/configure program. It
should also accept the --with-tcl= and --with-tclinclude= options in
the conventional way.
The generated "Makefile" must be one suitable for controlling the operations
of a `make` program. The following targets must be defined:
<default>: Perform a build of the runtime components of the
|
| ︙ | ︙ |
Changes to tests/aaa_exit.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994-1997 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994-1997 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::*
}
test exit-1.1 {normal, quick exit} {
set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 0;exit}\"" r]
set aft [after 1000 {set done "Quick exit hangs !!!"}]
fileevent $f readable {after cancel $aft;set done OK}
|
| ︙ | ︙ |
Changes to tests/all.tcl.
1 2 3 | # all.tcl -- # # This file contains a top-level script to run all of the Tcl | | | 1 2 3 4 5 6 7 8 9 10 11 | # all.tcl -- # # This file contains a top-level script to run all of the Tcl # tests. Execute it by invoking "source all.tcl" when running tcltest # in this directory. # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2000 by Ajuba Solutions # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
| ︙ | ︙ |
Changes to tests/append.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994-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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994-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::*
}
unset -nocomplain x
test append-1.1 {append command} {
unset -nocomplain x
list [append x 1 2 abc "long string"] $x
|
| ︙ | ︙ |
Changes to tests/appendComp.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994-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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994-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::*
}
catch {unset x}
test appendComp-1.1 {append command} -setup {
unset -nocomplain x
} -body {
|
| ︙ | ︙ | |||
355 356 357 358 359 360 361 |
append myvar a
info exists ::result
}
bar
} -result {0}
test appendComp-8.1 {defer error to runtime} -setup {
| | | | | 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 |
append myvar a
info exists ::result
}
bar
} -result {0}
test appendComp-8.1 {defer error to runtime} -setup {
interp create child
} -body {
child eval {
proc foo {} {
proc append args {}
append
}
foo
}
} -cleanup {
interp delete child
} -result {}
# New tests for bug 3057639 to show off the more consistent behaviour of
# lappend in both direct-eval and bytecompiled code paths (see append.test for
# the direct-eval variants). lappend now behaves like append. 9.0/1 lappend -
# 9.2/3 append.
|
| ︙ | ︙ |
Changes to tests/apply.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 |
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2005-2006 Miguel Sofer
#
# 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]} {
| | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2005-2006 Miguel Sofer
#
# 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::*
}
if {[info commands ::apply] eq {}} {
return
}
|
| ︙ | ︙ |
Changes to tests/assocd.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # This file tests the AssocData facility of Tcl # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994 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. | > | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# This file tests the AssocData facility of Tcl
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testgetassocdata [llength [info commands testgetassocdata]]
testConstraint testsetassocdata [llength [info commands testsetassocdata]]
testConstraint testdelassocdata [llength [info commands testdelassocdata]]
|
| ︙ | ︙ |
Changes to tests/async.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994-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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994-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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testasync [llength [info commands testasync]]
|
| ︙ | ︙ |
Added tests/auto-files.zip.
cannot compute difference between binary files
Added tests/auto0/auto1/file1.tcl.
> > > | 1 2 3 |
proc report1 {args} {
return ok1
}
|
Added tests/auto0/auto1/package1.tcl.
> > > > > | 1 2 3 4 5 |
proc HeresPackage1 {args} {
return OK1
}
package provide SafeTestPackage1 1.2.3
|
Added tests/auto0/auto1/pkgIndex.tcl.
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 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]] |
Added tests/auto0/auto1/tclIndex.
> > > > > > > > > | 1 2 3 4 5 6 7 8 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]] |
Added tests/auto0/auto2/file2.tcl.
> > > | 1 2 3 |
proc report2 {args} {
return ok2
}
|
Added tests/auto0/auto2/package2.tcl.
> > > > > | 1 2 3 4 5 |
proc HeresPackage2 {args} {
return OK2
}
package provide SafeTestPackage2 2.3.4
|
Added tests/auto0/auto2/pkgIndex.tcl.
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 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]] |
Added tests/auto0/auto2/tclIndex.
> > > > > > > > > | 1 2 3 4 5 6 7 8 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]] |
Added tests/auto0/modules/mod1/test1-1.0.tm.
> > > > > | 1 2 3 4 5 |
namespace eval mod1::test1 {}
proc mod1::test1::try1 args {
return res1
}
|
Added tests/auto0/modules/mod2/test2-2.0.tm.
> > > > > | 1 2 3 4 5 |
namespace eval mod2::test2 {}
proc mod2::test2::try2 args {
return res2
}
|
Added tests/auto0/modules/test0-0.5.tm.
> > > > > | 1 2 3 4 5 |
namespace eval test0 {}
proc test0::try0 args {
return res0
}
|
Changes to tests/autoMkindex.test.
1 2 3 4 5 6 7 8 9 10 11 12 |
# Commands covered: auto_mkindex auto_import
#
# This file contains tests related to autoloading and generating the
# autoloading index.
#
# Copyright (c) 1998 Lucent Technologies, 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: auto_mkindex auto_import
#
# This file contains tests related to autoloading and generating the
# autoloading index.
#
# Copyright (c) 1998 Lucent Technologies, 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::*
}
makeFile {# Test file for:
# auto_mkindex
#
# This file provides example cases for testing the Tcl autoloading facility.
|
| ︙ | ︙ | |||
142 143 144 145 146 147 148 |
return $result
} -cleanup {
namespace delete tcl_autoMkindex_tmp
} -result "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {normal $element} {top $element}"
test autoMkindex-2.1 {commands on the autoload path can be imported} -setup {
file delete tclIndex
| | | | | 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 |
return $result
} -cleanup {
namespace delete tcl_autoMkindex_tmp
} -result "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {normal $element} {top $element}"
test autoMkindex-2.1 {commands on the autoload path can be imported} -setup {
file delete tclIndex
interp create child
} -body {
auto_mkindex . autoMkindex.tcl
child eval {
namespace eval blt {}
set auto_path [linsert $auto_path 0 .]
set info [list [catch {namespace import buried::*} result] $result]
foreach name [lsort [info commands pub_*]] {
lappend info $name [namespace origin $name]
}
return $info
}
} -cleanup {
interp delete child
} -result "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two"
# Test auto_mkindex hooks
# Child hook executes interesting code in the interp used to watch code.
test autoMkindex-3.1 {childHook} -setup {
file delete tclIndex
|
| ︙ | ︙ | |||
331 332 333 334 335 336 337 |
test autoMkindex-5.2 {correctly locate auto loaded procs with []} -setup {
file delete tclIndex
makeDirectory pkg
makeFile {
proc {[magic mojo proc]} {} {}
} [file join pkg magicchar2.tcl]
set result {}
| | | | | | | 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
test autoMkindex-5.2 {correctly locate auto loaded procs with []} -setup {
file delete tclIndex
makeDirectory pkg
makeFile {
proc {[magic mojo proc]} {} {}
} [file join pkg magicchar2.tcl]
set result {}
interp create child
} -body {
auto_mkindex . pkg/magicchar2.tcl
# Make a child interp to test the autoloading
child eval {lappend auto_path [pwd]}
child eval {catch {{[magic mojo proc]}}}
} -cleanup {
interp delete child
removeFile [file join pkg magicchar2.tcl]
removeDirectory pkg
} -result 0
# Clean up.
unset result
|
| ︙ | ︙ |
Changes to tests/basic.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | # # Copyright (c) 1997 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. | > | | > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
#
# Copyright (c) 1997 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
testConstraint testcreatecommand [llength [info commands testcreatecommand]]
|
| ︙ | ︙ | |||
995 996 997 998 999 1000 1001 |
testevalex {set ::context $x} global
}
namespace delete ns
set ::context
} {global}
test basic-50.1 {[586e71dce4] EvalObjv level #0 exception handling} -setup {
| | | | | 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 |
testevalex {set ::context $x} global
}
namespace delete ns
set ::context
} {global}
test basic-50.1 {[586e71dce4] EvalObjv level #0 exception handling} -setup {
interp create child
interp alias {} foo child return
} -body {
list [catch foo m] $m
} -cleanup {
unset -nocomplain m
interp delete child
} -result {0 {}}
# Clean up after expand tests
unset noComp l1 l2 constraints
rename l3 {}
rename run {}
|
| ︙ | ︙ |
Changes to tests/binary.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# This file tests the tclBinary.c file and the "binary" Tcl command.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1997 by 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# This file tests the tclBinary.c file and the "binary" Tcl command.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1997 by 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::*
}
testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}]
testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}]
testConstraint testbytestring [llength [info commands testbytestring]]
# Big test for correct ordering of data in [expr]
|
| ︙ | ︙ |
Changes to tests/chan.test.
1 2 3 4 5 6 7 8 9 10 |
# This file contains a collection of tests for the Tcl built-in 'chan'
# command. Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
# Copyright (c) 2005 Donal K. Fellows
#
# 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
# This file contains a collection of tests for the Tcl built-in 'chan'
# command. Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
# Copyright (c) 2005 Donal K. Fellows
#
# 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::*
}
#
# Note: The tests for the chan methods "create" and "postevent"
# currently reside in the file "ioCmd.test".
#
|
| ︙ | ︙ | |||
169 170 171 172 173 174 175 |
set l [string length $line]
set e [chan eof $sock]
set b [chan blocked $sock]
set i [chan pending input $sock]
lappend ::chan-16.9-data $r $l $e $b $i
| | | 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 |
set l [string length $line]
set e [chan eof $sock]
set b [chan blocked $sock]
set i [chan pending input $sock]
lappend ::chan-16.9-data $r $l $e $b $i
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]
set ::chan-16.9-done 1
chan event $sock readable {}
} else {
after idle chan-16.9-client
|
| ︙ | ︙ |
Changes to tests/chanio.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 |
# Copyright (c) 1994-1997 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]} {
| | > > > > | > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
# Copyright (c) 1994-1997 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::*
}
namespace eval ::tcl::test::io {
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
variable umaskValue
variable path
variable f
variable i
variable n
variable v
|
| ︙ | ︙ | |||
39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testchannel [llength [info commands testchannel]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
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)]}]
# You need a *very* special environment to do some tests. In particular,
# many file systems do not support large-files...
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2 if "umask" cannot be run, the
# tests will be skipped.
| > | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testchannel [llength [info commands testchannel]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
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...
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2 if "umask" cannot be run, the
# tests will be skipped.
|
| ︙ | ︙ | |||
5716 5717 5718 5719 5720 5721 5722 |
lappend x [catch {chan event $f readable}] \
[catch {chan event $f2 readable}] \
[catch {chan event $f3 readable}]
} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1}
# Execute these tests only if the "testfevent" command is present.
| | | 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 |
lappend x [catch {chan event $f readable}] \
[catch {chan event $f2 readable}] \
[catch {chan event $f3 readable}]
} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1}
# Execute these tests only if the "testfevent" command is present.
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 {
set x "no event"
chan event $f readable [namespace code {
set x "f triggered: [chan gets $f]"
chan event $f readable {}
|
| ︙ | ︙ | |||
6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 |
test chan-io-50.1 {testing handler deletion} -setup {
file delete $path(test1)
} -constraints testchannelevent -body {
set f [open $path(test1) w]
chan close $f
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code {
variable z called
testchannelevent $f delete 0
}]
| > > > | | > | 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 |
test chan-io-50.1 {testing handler deletion} -setup {
file delete $path(test1)
} -constraints testchannelevent -body {
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
}]
testservicemode 1
vwait z
after cancel $timer
set z
} -cleanup {
chan close $f
} -result called
test chan-io-50.2 {testing handler deletion with multiple handlers} -setup {
file delete $path(test1)
chan close [open $path(test1) w]
|
| ︙ | ︙ | |||
6470 6471 6472 6473 6474 6475 6476 |
update
} -result {{delrecursive calling recursive} {delrecursive deleting recursive}}
test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup {
file delete $path(test1)
set f [open $path(test1) w]
chan close $f
update
| | | 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 |
update
} -result {{delrecursive calling recursive} {delrecursive deleting recursive}}
test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup {
file delete $path(test1)
set f [open $path(test1) w]
chan close $f
update
} -constraints {testchannelevent testservicemode notOSX} -body {
proc notcalled {f} {
variable z
lappend z "notcalled was called!! $f"
}
proc del {f} {
variable u
variable z
|
| ︙ | ︙ |
Changes to tests/clock.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
#
# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved.
#
# 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
#
# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved.
#
# 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::*
}
if {[testConstraint win]} {
if {[catch {
::tcltest::loadTestedCommands
package require registry
|
| ︙ | ︙ |
Changes to tests/cmdAH.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# The file tests the tclCmdAH.c file.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1996-1998 by 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# The file tests the tclCmdAH.c file.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1996-1998 by 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testchmod [llength [info commands testchmod]]
|
| ︙ | ︙ | |||
1628 1629 1630 1631 1632 1633 1634 |
list [file channels $newFileId] \
[safeInterp eval [list file channels $newFileId]]
} [list $newFileId $newFileId]
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} {
| | | 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 |
list [file channels $newFileId] \
[safeInterp eval [list file channels $newFileId]]
} [list $newFileId $newFileId]
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 child
safeInterp eval [list puts $newFileId "hello"]
} {}
interp transfer {} $newFileId safeInterp
test cmdAH-31.11 {Tcl_FileObjCmd: channels in other interp} {
# $newFileId should now be visible only in safeInterp
list [file channels $newFileId] \
[safeInterp eval [list file channels $newFileId]]
|
| ︙ | ︙ |
Changes to tests/cmdIL.test.
1 2 3 4 5 6 7 8 9 10 11 |
# This file contains a collection of tests for the procedures in the file
# tclCmdIL.c. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1997 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]} {
| | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# This file contains a collection of tests for the procedures in the file
# tclCmdIL.c. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1997 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
testConstraint testobj [llength [info commands testobj]]
|
| ︙ | ︙ |
Changes to tests/cmdInfo.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994-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. | > | | > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994-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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testcmdinfo [llength [info commands testcmdinfo]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
|
| ︙ | ︙ |
Changes to tests/cmdMZ.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # The tests in this file cover the procedures in tclCmdMZ.c. # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 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. | > | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# The tests in this file cover the procedures in tclCmdMZ.c.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 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::*
}
namespace eval ::tcl::test::cmdMZ {
namespace import ::tcltest::cleanupTests
namespace import ::tcltest::customMatch
namespace import ::tcltest::makeFile
namespace import ::tcltest::removeFile
|
| ︙ | ︙ |
Changes to tests/compExpr-old.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 |
# Copyright (c) 1996-1997 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]} {
| | > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# Copyright (c) 1996-1997 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::*
}
::tcltest::loadTestedCommands
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
variable ieeeValues
|
| ︙ | ︙ |
Changes to tests/compExpr.test.
1 2 3 4 5 6 7 8 9 10 11 |
# This file contains a collection of tests for the procedures in the file
# tclCompExpr.c. Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
# Copyright (c) 1997 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# This file contains a collection of tests for the procedures in the file
# tclCompExpr.c. Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
# Copyright (c) 1997 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::*
}
::tcltest::loadTestedCommands
# Constrain memory leak tests
testConstraint memory [llength [info commands memory]]
|
| ︙ | ︙ | |||
336 337 338 339 340 341 342 |
proc getbytes {} {
set lines [split [memory info] \n]
lindex $lines 3 3
}
} -body {
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
| | | | | 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
proc getbytes {} {
set lines [split [memory info] \n]
lindex $lines 3 3
}
} -body {
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
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]
}
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
unset end i tmp
rename getbytes {}
|
| ︙ | ︙ |
Changes to tests/compile.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # This file contains tests for the files tclCompile.c, tclCompCmds.c and # tclLiteral.c # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (c) 1997 by 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. | > | | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# This file contains tests for the files tclCompile.c, tclCompCmds.c and
# tclLiteral.c
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1997 by 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint exec [llength [info commands exec]]
testConstraint memory [llength [info commands memory]]
testConstraint testevalex [llength [info commands testevalex]]
|
| ︙ | ︙ |
Changes to tests/concat.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994-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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994-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::*
}
test concat-1.1 {simple concatenation} {
concat a b c d e f g
} {a b c d e f g}
test concat-1.2 {merging lists together} {
|
| ︙ | ︙ |
Changes to tests/config.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 |
# Copyright (c) 1994-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]} {
| | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 1994-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::*
}
test pkgconfig-1.1 {query keys} {
lsort [::tcl::pkgconfig list]
} {64bit bindir,install bindir,runtime compile_debug compile_stats debug dllfile,runtime docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime mem_debug optimized profiled scriptdir,install scriptdir,runtime threaded zipfile,runtime}
test pkgconfig-1.2 {query keys multiple times} {
|
| ︙ | ︙ |
Changes to tests/coroutine.test.
1 2 3 4 5 6 7 8 9 10 11 12 |
# Commands covered: coroutine, yield, yieldto, [info coroutine]
#
# This file contains a collection of tests for experimental commands that are
# found in ::tcl::unsupported. The tests will migrate to normal test files
# if/when the commands find their way into the core.
#
# Copyright (c) 2008 by Miguel Sofer.
#
# 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: coroutine, yield, yieldto, [info coroutine]
#
# This file contains a collection of tests for experimental commands that are
# found in ::tcl::unsupported. The tests will migrate to normal test files
# if/when the commands find their way into the core.
#
# Copyright (c) 2008 by Miguel Sofer.
#
# 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testnrelevels [llength [info commands testnrelevels]]
|
| ︙ | ︙ | |||
767 768 769 770 771 772 773 |
coroutine demo apply {{} { foreach i {1 2} yield; error test }}
demo
set ::result none
tcl::unsupported::inject demo set ::result inject-executed
lappend ::result [catch {demo} err] $err
} -result {inject-executed 1 test}
test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body {
| | | | | | | | | | 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 |
coroutine demo apply {{} { foreach i {1 2} yield; error test }}
demo
set ::result none
tcl::unsupported::inject demo set ::result inject-executed
lappend ::result [catch {demo} err] $err
} -result {inject-executed 1 test}
test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body {
interp create child
child eval {
coroutine demo apply {{} { while {1} yield }}
demo
tcl::unsupported::inject demo set ::result inject-executed
}
interp delete child
} -result {}
test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body {
interp create child
child eval {
coroutine demo apply {{} { while {1} yield }}
demo
tcl::unsupported::inject demo set ::result inject-executed
}
child eval demo
set result [child eval {set ::result}]
interp delete child
set result
} -result {inject-executed}
test coroutine-9.1 {coroprobe with yield} -body {
coroutine demo apply {{} { foreach i {1 2} yield }}
list [coroprobe demo set i] [demo] [coroprobe demo set i] [demo]
} -cleanup {
|
| ︙ | ︙ |
Changes to tests/dcall.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: none # # This file contains a collection of tests for Tcl_CallWhenDeleted. # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994 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. | > | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Commands covered: none
#
# This file contains a collection of tests for Tcl_CallWhenDeleted.
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testdcall [llength [info commands testdcall]]
test dcall-1.1 {deletion callbacks} testdcall {
|
| ︙ | ︙ |
Changes to tests/dstring.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testdstring [llength [info commands testdstring]]
|
| ︙ | ︙ |
Changes to tests/encoding.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for tclEncoding.c # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright (c) 1997 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. | > | > > > < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# This file contains a collection of tests for tclEncoding.c
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1997 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::*
}
namespace eval ::tcl::test::encoding {
variable x
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
}
proc toutf {args} {
variable x
|
| ︙ | ︙ |
Changes to tests/env.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 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::*
}
loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
package require tcltests
|
| ︙ | ︙ | |||
322 323 324 325 326 327 328 |
}
info exists env(THIS_SHOULDNT_EXIST)
} -cleanup {
interp delete i
} -result {0}
| | | | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 |
}
info exists env(THIS_SHOULDNT_EXIST)
} -cleanup {
interp delete i
} -result {0}
test env-5.3 {corner cases: unset the env in parent should unset child} -setup {
setup1
interp create i
} -body {
# 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)]
unset env(THIS_SHOULD_EXIST)
lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}]
} -cleanup {
cleanup1
|
| ︙ | ︙ |
Changes to tests/error.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994-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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994-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::*
}
testConstraint memory [llength [info commands memory]]
customMatch pairwise {apply {{a b} {
string equal [lindex $b 0] [lindex $b 1]
}}}
|
| ︙ | ︙ |
Changes to tests/eval.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 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::*
}
test eval-1.1 {single argument} {
eval {format 22}
} 22
test eval-1.2 {multiple arguments} {
|
| ︙ | ︙ |
Changes to tests/event.test.
1 2 3 4 5 6 7 8 9 10 11 | # This file contains a collection of tests for the procedures in the file # tclEvent.c, which includes the "update", and "vwait" Tcl commands. Sourcing # this file into Tcl runs the tests and generates output for errors. No # output means no errors were found. # # Copyright (c) 1995-1997 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# This file contains a collection of tests for the procedures in the file
# tclEvent.c, which includes the "update", and "vwait" Tcl commands. Sourcing
# this file into Tcl runs the tests and generates output for errors. No
# output means no errors were found.
#
# Copyright (c) 1995-1997 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 tcltest 2.5
namespace import -force ::tcltest::*
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
}
|
| ︙ | ︙ |
Changes to tests/exec.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # 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. | > | | > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
package require tcltests
# All tests require the "exec" command.
# Skip them if exec is not defined.
|
| ︙ | ︙ |
Changes to tests/execute.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 |
# Copyright (c) 1997 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]} {
| | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# Copyright (c) 1997 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
| ︙ | ︙ | |||
649 650 651 652 653 654 655 |
proc llength {args} {return AHA!}
}
lappend result [namespace eval foo $script]
} -cleanup {
namespace delete foo
} -result {0 AHA!}
test execute-6.9 {TclCompEvalObj: bytecode interp validation} -setup {
| | | | | | | | | | | | | | | | | | | | | | | | | | 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 |
proc llength {args} {return AHA!}
}
lappend result [namespace eval foo $script]
} -cleanup {
namespace delete foo
} -result {0 AHA!}
test execute-6.9 {TclCompEvalObj: bytecode interp validation} -setup {
interp create child
} -body {
set script { llength {} }
child eval {proc llength args {return AHA!}}
set result {}
lappend result [if 1 $script]
lappend result [child eval $script]
} -cleanup {
interp delete child
} -result {0 AHA!}
test execute-6.10 {TclCompEvalObj: bytecode interp validation} -body {
set script { llength {} }
interp create child
set result {}
lappend result [child eval $script]
interp delete child
interp create child
lappend result [child eval $script]
} -cleanup {
catch {interp delete child}
} -result {0 0}
test execute-6.11 {Tcl_ExprObj: exprcode interp validation} -setup {
interp create child
} -constraints testexprlongobj -body {
set e { [llength {}]+1 }
set result {}
load {} Tcltest child
interp alias {} e child testexprlongobj
lappend result [e $e]
interp delete child
interp create child
load {} Tcltest child
interp alias {} e child testexprlongobj
lappend result [e $e]
} -cleanup {
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 child
} -body {
set e { [llength {}]+1 }
set result {}
interp alias {} e child expr
lappend result [e $e]
interp delete child
interp create child
interp alias {} e child expr
lappend result [e $e]
} -cleanup {
interp delete child
} -result {1 1}
test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} -body {
set e { [llength {}]+1 }
set result {}
lappend result [expr $e]
set origName [namespace which llength]
rename $origName llength.orig
|
| ︙ | ︙ | |||
739 740 741 742 743 744 745 |
proc llength {args} {return 1}
}
lappend result [namespace eval foo [list expr $e]]
} -cleanup {
namespace delete foo
} -result {1 2}
test execute-6.16 {Tcl_ExprObj: exprcode interp validation} -setup {
| | | | | | 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 |
proc llength {args} {return 1}
}
lappend result [namespace eval foo [list expr $e]]
} -cleanup {
namespace delete foo
} -result {1 2}
test execute-6.16 {Tcl_ExprObj: exprcode interp validation} -setup {
interp create child
} -body {
set e { [llength {}]+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 child
} -result {1 2}
test execute-6.17 {Tcl_ExprObj: exprcode context validation} -body {
proc foo e {set v 0; expr $e}
proc bar e {set v 1; expr $e}
set e { $v }
set result {}
lappend result [foo $e]
|
| ︙ | ︙ | |||
974 975 976 977 978 979 980 |
} -match glob -result {-code 1 -level 0 -errorstack * -errorcode NONE -errorinfo {FOO
while executing
"error FOO"
invoked from within
"catch \[list error FOO\] m o"} -errorline 2}
test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup {
| | | | | | | | | | | | | | | | | | | | | | | 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 |
} -match glob -result {-code 1 -level 0 -errorstack * -errorcode NONE -errorinfo {FOO
while executing
"error FOO"
invoked from within
"catch \[list error FOO\] m o"} -errorline 2}
test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup {
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 ""} {
proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
}
}
} -body {
child eval {
lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
}
child eval {
set i 0; while {[incr i] < 3} {
lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
}
}
child eval {
set i 0; while {[incr i] < 3} {
lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
}
}
child eval {
catch {
lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C;
}
}
child eval {set res}
} -cleanup {
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 child
child eval {
package require tcltest 2.5
catch [list package require -exact Tcltest [info patchlevel]]
::tcltest::loadTestedCommands
if {[namespace which -command testbumpinterpepoch] eq ""} {
proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
}
}
} -body {
set res {}
lappend res [catch {
child eval {
lappend res A; testbumpinterpepoch; lappend res B; return -code error test; lappend res C;
}
} e] $e
lappend res [catch {
child eval {
lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C;
}
} e] $e
lappend res [catch {
child eval {
lappend res A; testbumpinterpepoch; lappend res B; return -code return test; lappend res C;
}
} e] $e
lappend res [catch {
child eval {
lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
}
} e] $e
list $res [child eval {set res}]
} -cleanup {
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]} {
set c 0
catch {
catch {error foo}
expr {1/$c}
}
if {[string match *foo* $::errorInfo]} {
set result "Bad errorInfo: $::errorInfo"
} else {
set result SUCCESS
}
set result
} SUCCESS
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 child
} -body {
# If [Bug 2802881] is not fixed, this will segfault
child eval {
trace add variable ::errorInfo write {expr {$foo} ;#}
proc demo {} {a {}{}}
demo
}
} -cleanup {
interp delete child
} -returnCodes error -match glob -result *
test execute-10.3 {Bug 3072640} -setup {
proc generate {n} {
for {set i 0} {$i < $n} {incr i} {
yield $i
}
}
|
| ︙ | ︙ | |||
1095 1096 1097 1098 1099 1100 1101 |
unset ::foo
rename generate {}
rename t {}
rename coro {}
} -result 4
test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup {
| | | | | 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 |
unset ::foo
rename generate {}
rename t {}
rename coro {}
} -result 4
test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup {
interp create child
} -body {
child eval {
set x [lrepeat 1320 199]
for {set i 0} {$i < 20} {incr i} {
lappend x $i
lsort -integer $x
}
# Crashes on failure
return ok
}
} -cleanup {
interp delete child
} -result ok
test execute-11.2 {Bug 268b23df11} -setup {
proc zero {} {return 0}
proc crash {} {expr {abs([zero])}}
proc noop args {}
trace add execution crash enterstep noop
|
| ︙ | ︙ |
Changes to tests/expr-old.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | > | | > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testexprlong [llength [info commands testexprlong]]
testConstraint testexprdouble [llength [info commands testexprdouble]]
testConstraint testexprstring [llength [info commands testexprstring]]
|
| ︙ | ︙ |
Changes to tests/expr.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# Commands covered: expr
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: expr
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 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::*
}
::tcltest::loadTestedCommands
# Determine if "long int" type is a 32 bit number and if the wide
# type is a 64 bit number on this machine.
|
| ︙ | ︙ |
Changes to tests/fCmd.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# This file tests the tclFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# This file tests the tclFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
cd [temporaryDirectory]
|
| ︙ | ︙ |
Changes to tests/fileName.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# This file tests the filename manipulation routines.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. 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) 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]} {
| | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# This file tests the filename manipulation routines.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. 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) 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testtranslatefilename [llength [info commands testtranslatefilename]]
testConstraint linkDirectory 1
|
| ︙ | ︙ |
Changes to tests/fileSystem.test.
1 2 3 4 5 6 7 8 9 10 11 | # This file tests the filesystem and vfs internals. # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (c) 2002 Vincent Darley. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. | < > > > | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# This file tests the filesystem and vfs internals.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 2002 Vincent Darley.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
namespace eval ::tcl::test::fileSystem {
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
catch {
file delete -force link.file
file delete -force dir.link
file delete -force [file join dir.dir linkinside.file]
}
|
| ︙ | ︙ |
Changes to tests/fileSystemEncoding.test.
1 2 3 4 5 6 7 8 9 |
#! /usr/bin/env tclsh
# Copyright (c) 2019 Poor Yorick
if {[string equal $::tcl_platform(os) "Windows NT"]} {
return
}
namespace eval ::tcl::test::fileSystemEncoding {
| > > | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
#! /usr/bin/env tclsh
# Copyright (c) 2019 Poor Yorick
if {[string equal $::tcl_platform(os) "Windows NT"]} {
return
}
namespace eval ::tcl::test::fileSystemEncoding {
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
variable fname1 \u767b\u9e1b\u9d72\u6a13
proc autopath {} {
global auto_path
set scriptpath [info script]
set scriptpathnorm [file dirname [file normalize $scriptpath/...]]
|
| ︙ | ︙ |
Changes to tests/for-old.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 |
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# 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]} {
| | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# 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::*
}
# Check "for" and its use of continue and break.
catch {unset a i}
test for-old-1.1 {for tests} {
|
| ︙ | ︙ |
Changes to tests/for.test.
1 2 3 4 5 6 7 8 9 10 11 12 |
# Commands covered: for, continue, break
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: for, continue, break
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# 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::*
}
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc meminfo {} {lindex [split [memory info] "\n"] 3 3}
|
| ︙ | ︙ |
Changes to tests/foreach.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# Commands covered: foreach, continue, break
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: foreach, continue, break
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# 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::*
}
catch {unset a}
catch {unset x}
# Basic "foreach" operation.
|
| ︙ | ︙ |
Changes to tests/format.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# Commands covered: format
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: format
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# 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::*
}
# %u output depends on word length, so this test is not portable.
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
|
| ︙ | ︙ |
Changes to tests/get.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# Commands covered: none
#
# This file contains a collection of tests for the procedures in the
# file tclGet.c. 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.
if {"::tcltest" ni [namespace children]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: none
#
# This file contains a collection of tests for the procedures in the
# file tclGet.c. 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testgetint [llength [info commands testgetint]]
|
| ︙ | ︙ |
Changes to tests/history.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 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::*
}
# The history command might be autoloaded...
if {[catch {history}]} {
testConstraint history 0
} else {
|
| ︙ | ︙ |
Changes to tests/http.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: http::config, http::geturl, http::wait, http::reset # # This file contains a collection of tests for the http script library. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. | > | | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
# Commands covered: http::config, http::geturl, http::wait, http::reset
#
# This file contains a collection of tests for the http script library.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Ajuba Solutions.
#
# 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::*
}
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 child interp"}
set interp [interp create http2]
$interp eval [list set http2 "running"]
$interp eval [list set argv $argv]
$interp eval [list source [info script]]
interp delete $interp
return
}
|
| ︙ | ︙ |
Changes to tests/http11.test.
1 2 3 4 5 6 7 8 9 | # http11.test -- -*- tcl-*- # # Test HTTP/1.1 features. # # Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | > | | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# http11.test -- -*- tcl-*-
#
# Test HTTP/1.1 features.
#
# Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# 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::*
}
package require http 2.9
# start the server
variable httpd_output
proc create_httpd {} {
proc httpd_read {chan} {
variable httpd_output
if {[gets $chan line] >= 0} {
#puts stderr "read '$line'"
set httpd_output $line
}
if {[eof $chan]} {
puts stderr "eof from httpd"
fileevent $chan readable {}
close $chan
|
| ︙ | ︙ | |||
275 276 277 278 279 280 281 282 283 284 285 286 287 288 |
http::cleanup $tok
http::cleanup $toj
halt_httpd
http::config -zip $zipTmp
} -result {ok {HTTP/1.1 200 OK} ok {} {} 0 keep-alive -- ok {HTTP/1.1 200 OK} ok {} {} 1 keep-alive}
# -------------------------------------------------------------------------
test http11-2.0 "-channel" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
-timeout 5000 -channel $chan]
| > > > > > > > > > > > > > > | 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 |
http::cleanup $tok
http::cleanup $toj
halt_httpd
http::config -zip $zipTmp
} -result {ok {HTTP/1.1 200 OK} ok {} {} 0 keep-alive -- ok {HTTP/1.1 200 OK} ok {} {} 1 keep-alive}
# -------------------------------------------------------------------------
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+]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
-timeout 5000 -channel $chan]
|
| ︙ | ︙ | |||
371 372 373 374 375 376 377 378 379 380 381 382 383 384 |
[meta $tok transfer-encoding]
} -cleanup {
http::cleanup $tok
close $chan
removeFile testfile.tmp
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok close {} chunked}
test http11-2.5 "-channel,encoding unsupported" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
-timeout 5000 -channel $chan \
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 |
[meta $tok transfer-encoding]
} -cleanup {
http::cleanup $tok
close $chan
removeFile testfile.tmp
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+]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
-timeout 5000 -channel $chan \
|
| ︙ | ︙ | |||
550 551 552 553 554 555 556 557 558 559 560 561 562 563 |
proc handler {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])"
return [string length $chunk]
}
test http11-3.0 "-handler,close,identity" -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 handler testdata]]]
| > > > > > > > > > > | 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 |
proc handler {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])"
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 ""
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
-timeout 10000 -handler [namespace code [list handler testdata]]]
|
| ︙ | ︙ | |||
622 623 624 625 626 627 628 629 630 631 632 633 634 635 |
[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 close {} {} 0}
test http11-4.0 "normal post request" -setup {
variable httpd [create_httpd]
} -body {
set query [http::formatQuery q 1 z 2]
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
-query $query -timeout 10000]
http::wait $tok
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 |
[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 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 {
set query [http::formatQuery q 1 z 2]
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
-query $query -timeout 10000]
http::wait $tok
|
| ︙ | ︙ |
Changes to tests/httpPipeline.test.
1 2 3 4 5 6 7 8 9 10 | # httpPipeline.test # # Test HTTP/1.1 concurrent requests including # queueing, pipelining and retries. # # Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | > | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# httpPipeline.test
#
# Test HTTP/1.1 concurrent requests including
# queueing, pipelining and retries.
#
# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net>
#
# 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::*
}
package require http 2.9
set sourcedir [file normalize [file dirname [info script]]]
source [file join $sourcedir httpTest.tcl]
source [file join $sourcedir httpTestScript.tcl]
|
| ︙ | ︙ |
Changes to tests/httpTest.tcl.
| ︙ | ︙ | |||
56 57 58 59 60 61 62 |
# - Also writes them to stdout (using Puts) if ($testOptions(-verbose) > 0).
# - Also writes Log calls that do not have "^", if ($testOptions(-verbose) > 1).
proc http::Log {args} {
variable TestStartTimeInMs
set time [expr {[clock milliseconds] - $TestStartTimeInMs}]
set txt [list $time {*}$args]
| | | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 |
# - Also writes them to stdout (using Puts) if ($testOptions(-verbose) > 0).
# - Also writes Log calls that do not have "^", if ($testOptions(-verbose) > 1).
proc http::Log {args} {
variable TestStartTimeInMs
set time [expr {[clock milliseconds] - $TestStartTimeInMs}]
set txt [list $time {*}$args]
if {[string first ^ $txt] >= 0} {
::httpTest::LogRecord $txt
::httpTest::Puts $txt
} elseif {$::httpTest::testOptions(-verbose) > 1} {
::httpTest::Puts $txt
}
return
}
|
| ︙ | ︙ | |||
82 83 84 85 86 87 88 |
set pos [string first ^ $txt]
set len [string length $txt]
if {$pos > $len - 3} {
puts stdout "Logging Error: $txt"
puts stdout "Fix this call to Log in http-*.tm so it has ^ then\
a letter then a numeral."
flush stdout
| | | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 |
set pos [string first ^ $txt]
set len [string length $txt]
if {$pos > $len - 3} {
puts stdout "Logging Error: $txt"
puts stdout "Fix this call to Log in http-*.tm so it has ^ then\
a letter then a numeral."
flush stdout
} elseif {$pos < 0} {
# Called by mistake.
} else {
set letter [string index $txt [incr pos]]
set number [string index $txt [incr pos]]
# Max 9 requests!
lappend testResults [list $letter $number]
}
|
| ︙ | ︙ | |||
149 150 151 152 153 154 155 |
for {set i 1} {$i <= $n} {incr i} {
if {$i in $badTrans} {
continue
}
set myStart [lsearch -exact $someResults [list B $i]]
set myEnd [lsearch -exact $someResults [list $term $i]]
| | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 |
for {set i 1} {$i <= $n} {incr i} {
if {$i in $badTrans} {
continue
}
set myStart [lsearch -exact $someResults [list B $i]]
set myEnd [lsearch -exact $someResults [list $term $i]]
if {($myStart < 0 || $myEnd < 0)} {
set res "Cannot find positions of transaction $i"
append msg $res \n
Puts $res
}
set overlaps {}
for {set j $myStart} {$j <= $myEnd} {incr j} {
|
| ︙ | ︙ | |||
370 371 372 373 374 375 376 |
# were scheduled (by A) but not completed (by F). Pass each segment to
# MostAnalysis for processing.
proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPiped} {
variable testOptions
set nextRetry [lsearch -glob -index 0 $someResults {[PQR]}]
| | | | | 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 |
# were scheduled (by A) but not completed (by F). Pass each segment to
# MostAnalysis for processing.
proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPiped} {
variable testOptions
set nextRetry [lsearch -glob -index 0 $someResults {[PQR]}]
if {$nextRetry < 0} {
return [MostAnalysis $someResults $n $msg $skipOverlaps $notIncluded $notPiped]
}
set badTrans $notIncluded
set tryCount 0
set try $nextRetry
incr tryCount
lassign [lindex $someResults $try] letter number
Puts "Processing retry [lindex $someResults $try]"
set beforeTry [lrange $someResults 0 $try-1]
Puts [join $beforeTry \n]
set afterTry [lrange $someResults $try+1 end]
set dummyTry {}
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 < 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
Puts $res
if {$i ni $badTrans} {
lappend badTrans $i
} else {
}
} 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
Puts $res
lappend badTrans $i
lappend dummyTry [list A $i]
} else {
|
| ︙ | ︙ |
Changes to tests/httpcookie.test.
1 2 3 4 5 6 7 8 9 10 11 | # Commands covered: http::cookiejar # # This file contains a collection of tests for the cookiejar package. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright (c) 2014 Donal K. Fellows. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. | > | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Commands covered: http::cookiejar
#
# This file contains a collection of tests for the cookiejar package.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2014 Donal K. Fellows.
#
# 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::*
}
::tcltest::loadTestedCommands
testConstraint notOSXtravis [apply {{} {
upvar 1 env(TRAVIS_OSX_IMAGE) travis
return [expr {![info exists travis] || ![string match xcode* $travis]}]
}}]
|
| ︙ | ︙ |
Changes to tests/httpd11.tcl.
| ︙ | ︙ | |||
166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
}
}
set transfer chunked
} else {
set close 1
}
foreach pair [split $query &] {
if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""}
switch -exact -- $key {
close {set close 1 ; set transfer 0}
transfer {set transfer $val}
content-type {set type $val}
}
}
chan configure $chan -buffering line -encoding iso8859-1 -translation crlf
Puts $chan "$protocol $code"
Puts $chan "content-type: $type"
Puts $chan [format "x-crc32: %08x" [zlib crc32 $data]]
if {$req eq "POST"} {
Puts $chan [format "x-query-length: %d" [string length $query]]
}
| > > > > > | | > > > > | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 |
}
}
set transfer chunked
} else {
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"
Puts $chan "content-type: $type"
Puts $chan [format "x-crc32: %08x" [zlib crc32 $data]]
if {$req eq "POST"} {
Puts $chan [format "x-query-length: %d" [string length $query]]
}
if {$close && (!$nosendclose)} {
Puts $chan "connection: close"
}
Puts $chan "x-requested-encodings: [dict get? $meta accept-encoding]"
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"
}
if {$transfer eq "chunked"} {
Puts $chan "transfer-encoding: chunked"
}
puts $chan ""
|
| ︙ | ︙ | |||
224 225 226 227 228 229 230 |
proc Accept {chan addr port} {
coroutine client$chan Service $chan $addr $port
return
}
proc Control {chan} {
| | | 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 |
proc Accept {chan addr port} {
coroutine client$chan Service $chan $addr $port
return
}
proc Control {chan} {
if {[gets $chan line] >= 0} {
if {[string trim $line] eq "quit"} {
set ::forever 1
}
}
if {[eof $chan]} {
chan event $chan readable {}
}
|
| ︙ | ︙ |
Changes to tests/if-old.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 |
# Copyright (c) 1994-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]} {
| | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright (c) 1994-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::*
}
test if-old-1.1 {taking proper branch} {
set a {}
if 0 {set a 1} else {set a 2}
set a
|
| ︙ | ︙ |
Changes to tests/if.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# Commands covered: if
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: if
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 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::*
}
# Basic "if" operation.
catch {unset a}
test if-1.1 {TclCompileIfCmd: missing if/elseif test} -body {
|
| ︙ | ︙ |
Changes to tests/incr-old.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 |
# Copyright (c) 1994-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]} {
| | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright (c) 1994-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::*
}
catch {unset x}
test incr-old-1.1 {basic incr operation} {
set x 23
|
| ︙ | ︙ |
Changes to tests/incr.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# Commands covered: incr
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: incr
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 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::*
}
unset -nocomplain x i
proc readonly varName {
upvar 1 $varName var
trace add variable var write \
|
| ︙ | ︙ |
Changes to tests/indexObj.test.
1 2 3 4 5 6 7 8 9 10 11 |
# This file is a Tcl script to test out the the procedures in file
# tkIndexObj.c, which implement indexed table lookups. The tests here are
# organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1997 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# This file is a Tcl script to test out the the procedures in file
# tkIndexObj.c, which implement indexed table lookups. The tests here are
# organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1997 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testindexobj [llength [info commands testindexobj]]
|
| ︙ | ︙ |
Changes to tests/info.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 |
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# DO NOT DELETE THIS LINE
if {{::tcltest} ni [namespace children]} {
| | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# DO NOT DELETE THIS LINE
if {{::tcltest} ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint zlib [llength [info commands zlib]]
# Set up namespaces needed to test operation of "info args", "info body",
|
| ︙ | ︙ |
Changes to tests/init.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# Functionality covered: this file contains a collection of tests for the auto
# loading and namespaces.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1997 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Functionality covered: this file contains a collection of tests for the auto
# loading and namespaces.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1997 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::*
}
# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
test init-0.1 {no error on initialization phase (init.tcl)} -setup {
|
| ︙ | ︙ |
Changes to tests/interp.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# This file tests the multiple interpreter facility of Tcl
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. 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.
if {"::tcltest" ni [namespace children]} {
| | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
# This file tests the multiple interpreter facility of Tcl
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
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 children] {
interp delete $i
}
# Part 0: Check out options for interp command
test interp-1.1 {options for interp command} -returnCodes error -body {
interp
} -result {wrong # args: should be "interp cmd ?arg ...?"}
test interp-1.2 {options for interp command} -returnCodes error -body {
interp frobox
} -match glob -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
} ""
test interp-1.4 {options for interp command} -returnCodes error -body {
interp delete foo bar
} -result {could not find interpreter "foo"}
test interp-1.5 {options for interp command} -returnCodes error -body {
interp exists foo bar
} -result {wrong # args: should be "interp exists ?path?"}
#
# test interp-0.6 was removed
#
test interp-1.6 {options for interp command} -returnCodes error -body {
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
} -match glob -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
} -match glob -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
} -match glob -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"}
# Part 1: Basic interpreter creation tests:
test interp-2.1 {basic interpreter creation} {
interp create a
|
| ︙ | ︙ | |||
116 117 118 119 120 121 122 |
regexp "interp(\[0-9]+)" $x dummy anothernum
expr $anothernum - $thenum
} 1
test interp-2.13 {correct default when no $path arg is given} -body {
interp create --
} -match regexp -result {interp[0-9]+}
| | | | | | | | | | | | | | | | | | | | | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 |
regexp "interp(\[0-9]+)" $x dummy anothernum
expr $anothernum - $thenum
} 1
test interp-2.13 {correct default when no $path arg is given} -body {
interp create --
} -match regexp -result {interp[0-9]+}
foreach i [interp children] {
interp delete $i
}
# 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 children} {
interp create a
interp exists a
} 1
test interp-3.3 {testing interp exists and interp children} {
interp exists nonexistent
} 0
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 children} {
interp exists
} 1
test interp-3.7 {testing interp exists and interp children} -setup {
catch {interp create a}
} -body {
interp children
} -result a
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 children a]}
} -result 1
test interp-3.10 {testing interp exists and interp children} -setup {
catch {interp create a}
catch {interp create {a a2}}
} -body {
interp exists {a a2}
} -result 1
# Part 3: Testing "interp delete"
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 |
test interp-4.4 {testing interp delete} {
interp delete
} ""
test interp-4.5 {testing interp delete} {
interp create a
interp create {a x1}
interp delete {a x1}
| | | | | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 |
test interp-4.4 {testing interp delete} {
interp delete
} ""
test interp-4.5 {testing interp delete} {
interp create a
interp create {a x1}
interp delete {a x1}
expr {"x1" in [interp children a]}
} 0
test interp-4.6 {testing interp delete} {
interp create c1
interp create c2
interp create c3
interp delete c1 c2 c3
} ""
test interp-4.7 {testing interp delete} -returnCodes error -body {
interp create c1
interp create c2
interp delete c1 c2 c3
} -result {could not find interpreter "c3"}
test interp-4.8 {testing interp delete} -returnCodes error -body {
interp delete {}
} -result {cannot delete the current interpreter}
foreach i [interp children] {
interp delete $i
}
# Part 4: Consistency checking - all nondeleted interpreters should be
# there:
test interp-5.1 {testing consistency} {
interp children
} ""
test interp-5.2 {testing consistency} {
interp exists a
} 0
test interp-5.3 {testing consistency} {
interp exists nonexistent
} 0
|
| ︙ | ︙ | |||
243 244 245 246 247 248 249 |
interp eval {a x2} frob
} 36
catch {interp create {a x2}}
test interp-6.6 {testing eval} -returnCodes error -body {
interp eval {a x2} foo
} -result {invalid command name "foo"}
| | | | | | | | | | | | | | | | | | | 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 |
interp eval {a x2} frob
} 36
catch {interp create {a x2}}
test interp-6.6 {testing eval} -returnCodes error -body {
interp eval {a x2} foo
} -result {invalid command name "foo"}
# 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_parent
} foo
catch {a alias foo in_parent}
test interp-7.2 {testing basic alias creation} {
a alias bar in_parent a1 a2 a3
} bar
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_parent
test interp-7.4 {testing basic alias creation} {
a alias bar
} {in_parent a1 a2 a3}
test interp-7.5 {testing basic alias creation} {
lsort [a aliases]
} {bar foo}
test interp-7.6 {testing basic aliases arg checking} -returnCodes error -body {
a aliases too many args
} -result {wrong # args: should be "a aliases"}
# Part 7: testing basic alias invocation
test interp-8.1 {testing basic alias invocation} {
catch {interp create a}
a alias foo in_parent
a eval foo 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_parent a1 a2 a3
a eval bar 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
} -result {wrong # args: should be "a alias aliasName ?targetName? ?arg ...?"}
# 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-parent
list [catch {a eval zop} msg] $msg
} {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-parent
proc nonexistent-command-in-parent {} {return i_exist!}
a eval zop
} i_exist!
test interp-9.3 {testing aliases for hidden commands} {
catch {interp create a}
a eval {proc p {} {return ENTER_A}}
interp alias {} p a p
set res {}
|
| ︙ | ︙ | |||
325 326 327 328 329 330 331 |
lappend res [namespace eval tst a]
rename p {}
rename a {}
namespace delete tst
set res
} {GLOBAL GLOBAL}
| | | | 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 |
lappend res [namespace eval tst a]
rename p {}
rename a {}
namespace delete tst
set res
} {GLOBAL GLOBAL}
if {[info command nonexistent-command-in-parent] != ""} {
rename nonexistent-command-in-parent {}
}
# Part 9: Aliasing between interpreters
test interp-10.1 {testing aliasing between interpreters} {
catch {interp delete a}
catch {interp delete b}
interp create a
|
| ︙ | ︙ | |||
376 377 378 379 380 381 382 |
} a_alias
test interp-10.6 {testing aliasing between interpreters} {
catch {interp delete a}
catch {interp delete b}
interp create a
interp create b
interp alias a a_command b b_command a1 a2 a3
| | | | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 |
} a_alias
test interp-10.6 {testing aliasing between interpreters} {
catch {interp delete a}
catch {interp delete b}
interp create a
interp create b
interp alias a a_command b b_command a1 a2 a3
b alias b_command in_parent b1 b2 b3
a eval a_command 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
interp alias "" foo a zoppo
a eval {proc zoppo {x} {list $x $x $x}}
set x [foo 33]
a eval {rename zoppo {}}
|
| ︙ | ︙ | |||
509 510 511 512 513 514 515 |
test interp-14.3 {testing interp aliases} {
catch {interp delete a}
interp create a
interp create {a x3}
interp alias {a x3} froboz "" puts
interp aliases {a x3}
} froboz
| | | 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 |
test interp-14.3 {testing interp aliases} {
catch {interp delete a}
interp create a
interp create {a x3}
interp alias {a x3} froboz "" puts
interp aliases {a x3}
} froboz
test interp-14.4 {testing interp alias - alias over parent} {
# SF Bug 641195
catch {interp delete a}
interp create a
list [catch {interp alias "" a a eval} msg] $msg [info commands a]
} {1 {cannot define or rename alias "a": interpreter deleted} {}}
test interp-14.5 {testing interp-alias: wrong # args} -body {
proc setx x {set x}
|
| ︙ | ︙ | |||
789 790 791 792 793 794 795 |
interp create x
interp alias x a x b
x eval rename a c
list [catch {x eval rename c b} msg] $msg
} {1 {cannot define or rename alias "b": would create a loop}}
#
| | | | | | | | | 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 |
interp create x
interp alias x a x b
x eval rename a c
list [catch {x eval rename c b} msg] $msg
} {1 {cannot define or rename alias "b": would create a loop}}
#
# 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 children} testinterpdelete {
list [catch {testinterpdelete} msg] $msg
} {1 {wrong # args: should be "testinterpdelete path"}}
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 children} testinterpdelete {
catch {interp delete a}
interp create a
interp create {a b}
testinterpdelete {a b}
} ""
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 children} testinterpdelete {
catch {interp delete a}
interp create a
interp create {a b}
interp alias {a b} dodel {} dodel
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 children} testinterpdelete {
catch {interp delete a}
interp create a
interp create {a b}
interp alias {a b} dodel {} dodel
proc dodel {x} {testinterpdelete $x}
list [catch {interp eval {a b} {dodel a}} msg] $msg
} {0 {}}
|
| ︙ | ︙ | |||
1611 1612 1613 1614 1615 1616 1617 |
interp delete a
set l
} {1 {cannot use namespace qualifiers in hidden command token (rename)}}
test interp-20.49 {interp invokehidden -namespace} -setup {
set script [makeFile {
set x [namespace current]
} script]
| | | | | | | | | | | | | | | 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 |
interp delete a
set l
} {1 {cannot use namespace qualifiers in hidden command token (rename)}}
test interp-20.49 {interp invokehidden -namespace} -setup {
set script [makeFile {
set x [namespace current]
} script]
interp create -safe child
} -body {
child invokehidden -namespace ::foo source $script
child eval {set ::foo::x}
} -cleanup {
interp delete child
removeFile script
} -result ::foo
test interp-20.50 {Bug 2486550} -setup {
interp create child
} -body {
child hide coroutine
child invokehidden coroutine
} -cleanup {
interp delete child
} -returnCodes error -match glob -result *
test interp-20.50.1 {Bug 2486550} -setup {
interp create child
} -body {
child hide coroutine
catch {child invokehidden coroutine} m o
dict get $o -errorinfo
} -cleanup {
unset -nocomplain m 0
interp delete child
} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?"
while executing
"coroutine"
invoked from within
"child invokehidden coroutine"}
test interp-21.1 {interp hidden} {
interp hidden {}
} ""
test interp-21.2 {interp hidden} {
interp hidden
} ""
|
| ︙ | ︙ | |||
2054 2055 2056 2057 2058 2059 2060 |
#
# Interps result transmission
#
test interp-26.1 {result code transmission : interp eval direct} {
# Test that all the possibles error codes from Tcl get passed up
| | | | 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 |
#
# Interps result transmission
#
test interp-26.1 {result code transmission : interp eval direct} {
# Test that all the possibles error codes from Tcl get passed up
# 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 {}
# use a for so if a return -code break 'escapes' we would notice
for {set code -1} {$code<=5} {incr code} {
lappend res [catch {interp eval a return -code $code} msg]
}
|
| ︙ | ︙ | |||
2081 2082 2083 2084 2085 2086 2087 |
lappend res [catch {interp eval a retcode $code} msg] $msg
}
interp delete a
set res
} {-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
| | | 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 |
lappend res [catch {interp eval a retcode $code} msg] $msg
}
interp delete a
set res
} {-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
# 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 {}
proc MyTestAlias {code} {
return -code $code ret$code
}
|
| ︙ | ︙ | |||
2176 2177 2178 2179 2180 2181 2182 |
invoked from within
"test"}
test interp-26.8 {errorInfo transmission: safe interps--bug 1637} -setup {
set interp [interp create -safe]
} -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
| | | 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 |
invoked from within
"test"}
test interp-26.8 {errorInfo transmission: safe interps--bug 1637} -setup {
set interp [interp create -safe]
} -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
# parent interpreter because it could contain sensitive information.
proc MyError {secret} {
return -code error "msg"
}
proc MyTestAlias {interp args} {
MyError "some secret"
}
interp alias $interp test {} MyTestAlias $interp
|
| ︙ | ︙ | |||
2271 2272 2273 2274 2275 2276 2277 |
lappend res [list [catch {interp eval $i {namespace eval foo {bar test2}}} msg] $msg]
} -cleanup {
interp delete $i
} -result {{bar called (::foo) (test1)} {1 {invalid command name "bar"}}}
test interp-27.6 {interp hidden & aliases & namespaces} -setup {
set i [interp create]
} -constraints knownBug -body {
| | | | | | | | | | | | | | | | | | | | | | 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 |
lappend res [list [catch {interp eval $i {namespace eval foo {bar test2}}} msg] $msg]
} -cleanup {
interp delete $i
} -result {{bar called (::foo) (test1)} {1 {invalid command name "bar"}}}
test interp-27.6 {interp hidden & aliases & namespaces} -setup {
set i [interp create]
} -constraints knownBug -body {
set v root-parent
namespace eval foo {
variable v foo-parent
proc bar {interp args} {
variable v
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-child
proc bar {args} {
variable v
return "child bar called ($v) ([namespace current]) ($args)"
}
}
}
set res [list [interp eval $i {namespace eval foo {bar test1}}]]
$i hide foo::bar
$i alias foo::bar foo::bar $i
set res [concat $res [interp eval $i {
set v root-child
namespace eval test {
variable v foo-test
namespace import ::foo::*
bar test2
}
}]]
} -cleanup {
namespace delete foo
interp delete $i
} -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-parent
namespace eval mfoo {
variable v foo-parent
proc bar {interp args} {
variable v
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-child
proc bar {args} {
variable v
return "child bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)"
}
}
set v root-child
namespace eval test {
variable v foo-test
namespace import ::foo::*
}
}
set res [list [interp eval $i {namespace eval test {bar test1}}]]
$i hide test::bar
$i alias test::bar mfoo::bar $i
set res [concat $res [interp eval $i {test::bar test2}]]
} -cleanup {
namespace delete mfoo
interp delete $i
} -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
proc bar {} {variable v; set v}
# next command would currently generate an unknown command "bar" error.
interp hide {} bar
}
namespace delete foo
list [catch {interp invokehidden {} foo::bar} msg] $msg
} {1 {invalid hidden command name "foo"}}
test interp-28.1 {getting fooled by child's namespace ?} -setup {
set i [interp create -safe]
proc parent {interp args} {interp hide $interp list}
} -body {
$i alias parent parent $i
set r [interp eval $i {
namespace eval foo {
proc list {args} {
return "dummy foo::list"
}
parent
}
info commands list
}]
} -cleanup {
rename parent {}
interp delete $i
} -result {}
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 {
$i eval {
set x {namespace children ::}
set y [list namespace children ::]
namespace delete {*}[filter [{*}$y]]
|
| ︙ | ︙ | |||
2428 2429 2430 2431 2432 2433 2434 |
} {1 {recursion limit must be > 0}}
test interp-29.1.7 {interp recursionlimit argument checking} {
interp create moo
set result [catch {interp recursionlimit moo [expr {wide(1)<<32}]} msg]
interp delete moo
list $result [string range $msg 0 35]
} {1 {integer value too large to represent}}
| | | | | | | 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 |
} {1 {recursion limit must be > 0}}
test interp-29.1.7 {interp recursionlimit argument checking} {
interp create moo
set result [catch {interp recursionlimit moo [expr {wide(1)<<32}]} msg]
interp delete moo
list $result [string range $msg 0 35]
} {1 {integer value too large to represent}}
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 {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 {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 {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 {child recursionlimit argument checking} {
interp create moo
set result [catch {moo recursionlimit [expr {wide(1)<<32}]} msg]
interp delete moo
list $result [string range $msg 0 35]
} {1 {integer value too large to represent}}
test interp-29.2.1 {query recursion limit} {
interp recursionlimit {}
|
| ︙ | ︙ | |||
2545 2546 2547 2548 2549 2550 2551 |
set i 0
list [catch p msg] $msg $i
}]
interp delete $i
set r
} {1 {too many nested evaluations (infinite loop?)} 49}
test interp-29.3.4 {recursion limit error reporting} {
| | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 |
set i 0
list [catch p msg] $msg $i
}]
interp delete $i
set r
} {1 {too many nested evaluations (infinite loop?)} 49}
test interp-29.3.4 {recursion limit error reporting} {
interp create child
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
interp recursionlimit {} 5
set x ok
}
}
}
}
} msg
}]
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 child
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
interp recursionlimit {} 4
set x ok
}
}
}
}
} msg
}]
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 child
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
interp recursionlimit {} 6
set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
#
# Note that TEBC does not verify the interp's nesting level itself; the nesting
# level will only be verified when it invokes a non-bcc'd command.
#
test interp-29.3.7a {recursion limit error reporting} {
interp create child
after 0 {interp recursionlimit child 5}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
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 child
after 0 {interp recursionlimit child 5}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
update
eval { # 5
set x ok
}
}
}
}
} msg
}]
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 child
after 0 {interp recursionlimit child 5}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set set set
$set x ok
}
}
}
}
} msg
}]
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 child
after 0 {interp recursionlimit child 4}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
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 child
after 0 {interp recursionlimit child 4}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
update
eval { # 5
set x ok
}
}
}
}
} msg
}]
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 child
after 0 {interp recursionlimit child 6}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
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 child
after 0 {interp recursionlimit child 6}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
set set set
$set x ok
}
}
}
}
} msg
}]
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 child
after 0 {child recursionlimit 4}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
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 child
after 0 {child recursionlimit 4}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
update
eval { # 5
set x ok
}
}
}
}
} msg
}]
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 child
after 0 {child recursionlimit 5}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
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 child
after 0 {child recursionlimit 5}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set set set
$set x ok
}
}
}
}
} msg
}]
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 child
after 0 {child recursionlimit 6}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set x ok
}
}
}
}
} msg
}]
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 child
after 0 {child recursionlimit 6}
set r1 [child eval {
catch { # nesting level 1
eval { # 2
eval { # 3
eval { # 4
eval { # 5
update
set set set
$set x ok
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.4.1 {recursion limit inheritance} {
set i [interp create]
set ii [interp eval $i {
interp recursionlimit {} 50
interp create
|
| ︙ | ︙ | |||
2912 2913 2914 2915 2916 2917 2918 |
set i 0
catch p
set i
}]
interp delete $i
set r
} 50
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 |
set i 0
catch p
set i
}]
interp delete $i
set r
} 50
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 childlimit [interp recursionlimit $i]
interp delete $i
list [expr {$before == $after}] $childlimit
} {1 20000}
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 childlimit [$i recursionlimit]
interp delete $i
list [expr {$before == $after}] $childlimit
} {1 20000}
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 childlimit [interp recursionlimit $i]
interp delete $i
list [expr {$before == $after}] $childlimit
} {1 20000}
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 childlimit [$i recursionlimit]
interp delete $i
list [expr {$before == $after}] $childlimit
} {1 20000}
test interp-29.6.1 {safe interpreter recursion limit} {
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 child -safe
set n [child recursionlimit]
interp delete child
set n
} 1000
test interp-29.6.3 {safe interpreter recursion limit} {
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 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 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 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 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 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 child -safe
set result [
child eval {
interp create child2 -safe
set n [catch {
interp recursionlimit child2 42
} msg]
list $n $msg
}
]
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 child -safe
set result [
child eval {
interp create child2 -safe
set n [catch {
child2 recursionlimit 42
} msg]
list $n $msg
}
]
interp delete child
set result
} {1 {permission denied: safe interpreters cannot change recursion limit}}
# # Deep recursion (into interps when the regular one fails):
# # still crashes...
# proc p {} {
|
| ︙ | ︙ | |||
3555 3556 3557 3558 3559 3560 3561 |
test interp-36.1 {interp bgerror syntax} -body {
interp bgerror
} -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"}
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 {
| | | | | | | | | | | | | | | | | | | | | | | | 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 |
test interp-36.1 {interp bgerror syntax} -body {
interp bgerror
} -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"}
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 child
} -body {
child bgerror x y
} -cleanup {
interp delete child
} -returnCodes error -result {wrong # args: should be "child bgerror ?cmdPrefix?"}
test interp-36.4 {ChildBgerror syntax} -setup {
interp create child
} -body {
child bgerror \{
} -cleanup {
interp delete child
} -returnCodes error -result {cmdPrefix must be list of length >= 1}
test interp-36.5 {ChildBgerror syntax} -setup {
interp create child
} -body {
child bgerror {}
} -cleanup {
interp delete child
} -returnCodes error -result {cmdPrefix must be list of length >= 1}
test interp-36.6 {ChildBgerror returns handler} -setup {
interp create child
} -body {
child bgerror {foo bar soom}
} -cleanup {
interp delete child
} -result {foo bar soom}
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 {
child eval {
variable done {}
after 0 error foo
after 10 [list ::set [namespace which -variable done] {}]
vwait [namespace which -variable done]
}
set result
} -cleanup {
variable result {}
unset -nocomplain result
interp delete child
} -result foo
test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup {
catch {interp delete a}
interp create a
set result {}
} -body {
|
| ︙ | ︙ | |||
3663 3664 3665 3666 3667 3668 3669 |
interp debug {} -frame 0 bogus
} -returnCodes {
error
} -result {wrong # args: should be "interp debug path ?-frame ?bool??"}
# cleanup
unset -nocomplain hidden_cmds
| | | 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 |
interp debug {} -frame 0 bogus
} -returnCodes {
error
} -result {wrong # args: should be "interp debug path ?-frame ?bool??"}
# cleanup
unset -nocomplain hidden_cmds
foreach i [interp children] {
interp delete $i
}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End:
|
Changes to tests/io.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 |
# Copyright (c) 1994-1997 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]} {
| | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright (c) 1994-1997 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 eval ::tcl::test::io {
namespace import ::tcltest::*
variable umaskValue
variable path
|
| ︙ | ︙ | |||
40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
testConstraint testchannel [llength [info commands testchannel]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
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)]}]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
| > | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 |
testConstraint testchannel [llength [info commands testchannel]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
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...
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
|
| ︙ | ︙ | |||
6083 6084 6085 6086 6087 6088 6089 |
lappend x [catch {fileevent $f readable}] \
[catch {fileevent $f2 readable}] \
[catch {fileevent $f3 readable}]
} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1}
# Execute these tests only if the "testfevent" command is present.
| | | 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 |
lappend x [catch {fileevent $f readable}] \
[catch {fileevent $f2 readable}] \
[catch {fileevent $f3 readable}]
} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1}
# Execute these tests only if the "testfevent" command is present.
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 {
set x "no event"
fileevent $f readable [namespace code {
set x "f triggered: [gets $f]"
fileevent $f readable {}
|
| ︙ | ︙ | |||
6891 6892 6893 6894 6895 6896 6897 |
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
set z
} -cleanup {
close $f
} -result {{delrecursive calling recursive} {delrecursive deleting recursive}}
| | | 6892 6893 6894 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 |
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
set z
} -cleanup {
close $f
} -result {{delrecursive calling recursive} {delrecursive deleting recursive}}
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]
close $f
proc notcalled {f} {
variable z
lappend z "notcalled was called!! $f"
|
| ︙ | ︙ | |||
8754 8755 8756 8757 8758 8759 8760 |
removeFile io-73.5
} -result [list 1 1 more\u00a0data 1]
test io-74.1 {[104f2885bb] improper cache validity check} -setup {
set fn [makeFile {} io-74.1]
set rfd [open $fn r]
testobj freeallvars
| | | | | 8755 8756 8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 8770 8771 8772 8773 8774 8775 8776 8777 8778 |
removeFile io-73.5
} -result [list 1 1 more\u00a0data 1]
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 child
} -constraints testobj -body {
teststringobj set 1 [string range $rfd 0 end]
read [teststringobj get 1]
testobj duplicate 1 2
interp transfer {} $rfd child
catch {read [teststringobj get 1]}
read [teststringobj get 2]
} -cleanup {
interp delete child
testobj freeallvars
removeFile io-74.1
} -returnCodes error -match glob -result {can not find channel named "*"}
# ### ### ### ######### ######### #########
# cleanup
|
| ︙ | ︙ |
Changes to tests/ioCmd.test.
| ︙ | ︙ | |||
2080 2081 2082 2083 2084 2085 2086 |
# during access from B. Must not crash, must return proper errors.
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>>
| | | 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 |
# during access from B. Must not crash, must return proper errors.
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 children
load {} Tcltest $ida
load {} Tcltest $idb
# Set up channel in interpreter
interp eval $ida $helperscript
set chan [interp eval $ida {
proc foo {args} {oninit seek; onfinal; track; return}
|
| ︙ | ︙ | |||
2118 2119 2120 2121 2122 2123 2124 |
-result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -match glob -body {
set ida [interp create];#puts <<$ida>>
set idb [interp create];#puts <<$idb>>
| | | 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 |
-result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -match glob -body {
set ida [interp create];#puts <<$ida>>
set idb [interp create];#puts <<$idb>>
# Magic to get the test* commands in the children
load {} Tcltest $ida
load {} Tcltest $idb
# Set up channel in thread
set chan [interp eval $ida $helperscript]
set chan [interp eval $ida {
proc foo {args} {
|
| ︙ | ︙ | |||
2160 2161 2162 2163 2164 2165 2166 |
interp delete $idb
} -constraints {testchannel} -result {Owner lost}
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
| | | | | 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 |
interp delete $idb
} -constraints {testchannel} -result {Owner lost}
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 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 child
} {}
# ### ### ### ######### ######### #########
## Same tests as above, but exercising the code forwarding and
## receiving driver operations to the originator thread.
# -*- tcl -*-
|
| ︙ | ︙ |
Changes to tests/ioTrans.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 2007 Andreas Kupries <andreask@activestate.com>
# <akupries@shaw.ca>
#
# 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 2007 Andreas Kupries <andreask@activestate.com>
# <akupries@shaw.ca>
#
# 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Custom constraints used in this file
|
| ︙ | ︙ | |||
33 34 35 36 37 38 39 |
# Helper commands to record the arguments to handler methods. Stored in a
# script so that the tests needing this code do not need their own copy but
# can access this variable.
set helperscript {
if {"::tcltest" ni [namespace children]} {
| | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
# Helper commands to record the arguments to handler methods. Stored in a
# script so that the tests needing this code do not need their own copy but
# can access this variable.
set helperscript {
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# This forces the return options to be in the order that the test expects!
variable optorder {
-code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?!
-errorstack !?!
|
| ︙ | ︙ | |||
1158 1159 1160 1161 1162 1163 1164 |
# --- === *** ###########################
# 'Pull the rug' tests. Create channel in a interpreter A, move to other
# interpreter B, destroy the origin interpreter (A) before or during access
# from B. Must not crash, must return proper errors.
test iortrans-11.0 {origin interpreter of moved transform gone} -setup {
set ida [interp create]; #puts <<$ida>>
set idb [interp create]; #puts <<$idb>>
| | | 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 |
# --- === *** ###########################
# 'Pull the rug' tests. Create channel in a interpreter A, move to other
# interpreter B, destroy the origin interpreter (A) before or during access
# from B. Must not crash, must return proper errors.
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 children
load {} Tcltest $ida
load {} Tcltest $idb
} -constraints {testchannel} -match glob -body {
# Set up channel and transform in interpreter
interp eval $ida $helperscript
interp eval $ida [list ::variable tempchan [tempchan]]
interp transfer {} $::tempchan $ida
|
| ︙ | ︙ | |||
1201 1202 1203 1204 1205 1206 1207 |
} -cleanup {
tempdone
interp delete $idb
} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
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>>
| | | 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 |
} -cleanup {
tempdone
interp delete $idb
} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
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 children
load {} Tcltest $ida
load {} Tcltest $idb
} -constraints {testchannel} -match glob -body {
# Set up channel in thread
set chan [interp eval $ida $helperscript]
interp eval $ida [list ::variable tempchan [tempchan]]
interp transfer {} $::tempchan $ida
|
| ︙ | ︙ | |||
1240 1241 1242 1243 1244 1245 1246 |
set res
}]
} -cleanup {
interp delete $idb
tempdone
} -result {Owner lost}
test iortrans-11.2 {delete interp of reflected transform} -setup {
| | | | | | | | | | 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 |
set res
}]
} -cleanup {
interp delete $idb
tempdone
} -result {Owner lost}
test iortrans-11.2 {delete interp of reflected transform} -setup {
interp create child
# Magic to get the test* commands into the child
load {} Tcltest child
} -constraints {testchannel} -body {
# Get base channel into the child
set c [tempchan]
testchannel cut $c
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}
}
set t [chan push $c [list driver $c]]
chan event $c readable no-op
}
interp delete child
} -cleanup {
tempdone
} -result {}
# ### ### ### ######### ######### #########
## Same tests as above, but exercising the code forwarding and receiving
## driver operations to the originator thread.
|
| ︙ | ︙ |
Changes to tests/iogt.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # Commands covered: transform, and stacking in general # # This file contains a collection of tests for Giot # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 2000 Ajuba Solutions. # Copyright (c) 2000 Andreas Kupries. # All rights reserved. | > | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# -*- tcl -*-
# Commands covered: transform, and stacking in general
#
# This file contains a collection of tests for Giot
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Copyright (c) 2000 Ajuba Solutions.
# Copyright (c) 2000 Andreas Kupries.
# All rights reserved.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
namespace eval ::tcl::test::iogt {
namespace import ::tcltest::*
|
| ︙ | ︙ |
Changes to tests/join.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 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::*
}
test join-1.1 {basic join commands} {
join {a b c} xyz
} axyzbxyzc
test join-1.2 {basic join commands} {
|
| ︙ | ︙ |
Changes to tests/lindex.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 |
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
#
# 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]} {
| | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
#
# 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
set minus -
|
| ︙ | ︙ | |||
444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 |
test lindex-17.0 {Bug 1718580} -body {
lindex {} end foo
} -match glob -result {bad index "foo"*} -returnCodes 1
test lindex-17.1 {Bug 1718580} -body {
lindex a end foo
} -match glob -result {bad index "foo"*} -returnCodes 1
catch { unset minus }
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 |
test lindex-17.0 {Bug 1718580} -body {
lindex {} end foo
} -match glob -result {bad index "foo"*} -returnCodes 1
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
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/link.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testlink [llength [info commands testlink]]
|
| ︙ | ︙ |
Changes to tests/linsert.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 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::*
}
catch {unset lis}
catch {rename p ""}
test linsert-1.1 {linsert command} {
|
| ︙ | ︙ |
Changes to tests/list.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 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::*
}
# First, a bunch of individual tests
test list-1.1 {basic tests} {list a b c} {a b c}
test list-1.2 {basic tests} {list {a b} c} {{a b} c}
|
| ︙ | ︙ |
Changes to tests/listObj.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testobj [llength [info commands testobj]]
|
| ︙ | ︙ |
Changes to tests/llength.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 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::*
}
test llength-1.1 {length of list} {
llength {a b c d}
} 4
test llength-1.2 {length of list} {
|
| ︙ | ︙ |
Changes to tests/lmap.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 |
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: $
if {"::tcltest" ni [namespace children]} {
| | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: $
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
unset -nocomplain a b i x
# ----- Non-compiled operation -----------------------------------------------
|
| ︙ | ︙ |
Changes to tests/load.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# Commands covered: load
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: load
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Figure out what extension is used for shared libraries on this
|
| ︙ | ︙ | |||
99 100 101 102 103 104 105 |
} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
while executing
"open non_existent"
invoked from within
"if 44 {open non_existent}"
invoked from within
"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}}
| | | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
while executing
"open non_existent"
invoked from within
"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, child interpreter} \
[list $dll $loaded] {
catch {interp delete x}
interp create x
set ::errorCode foo
set ::errorInfo bar
set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \
$msg $::errorInfo $::errorCode]
|
| ︙ | ︙ |
Changes to tests/lpop.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 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::*
}
unset -nocomplain no; # following tests expecting var "no" does not exists
test lpop-1.1 {error conditions} -returnCodes error -body {
lpop no
} -result {can't read "no": no such variable}
|
| ︙ | ︙ |
Changes to tests/lrange.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testpurebytesobj [llength [info commands testpurebytesobj]]
|
| ︙ | ︙ |
Changes to tests/lrepeat.test.
1 2 3 4 5 6 7 8 9 10 11 12 |
# Commands covered: lrepeat
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 2003 by Simon Geard.
#
# 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: lrepeat
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 2003 by Simon Geard.
#
# 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::*
}
## Arg errors
test lrepeat-1.1 {error cases} {
-body {
lrepeat
|
| ︙ | ︙ |
Changes to tests/lreplace.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 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::*
}
test lreplace-1.1 {lreplace command} {
lreplace {1 2 3 4 5} 0 0 a
} {a 2 3 4 5}
test lreplace-1.2 {lreplace command} {
|
| ︙ | ︙ |
Changes to tests/lsearch.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 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::*
}
set x {abcd bbcd 123 234 345}
test lsearch-1.1 {lsearch command} {
lsearch $x 123
} 2
|
| ︙ | ︙ |
Changes to tests/lset.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
#
# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
#
# 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
#
# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
#
# 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
proc failTrace {name1 name2 op} {
|
| ︙ | ︙ |
Changes to tests/lsetComp.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
#
# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
#
# 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
#
# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
#
# 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::*
}
# Procedure to evaluate a script within a proc, to test compilation
# functionality
proc evalInProc { script } {
|
| ︙ | ︙ |
Changes to tests/macOSXFCmd.test.
1 2 3 4 5 6 7 8 9 10 11 12 |
# This file tests the tclMacOSXFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 2003 Tcl Core Team.
#
# 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# This file tests the tclMacOSXFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 2003 Tcl Core Team.
#
# 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::*
}
# These tests really need to be run from a writable directory, which
# it is assumed [temporaryDirectory] is.
set oldcwd [pwd]
cd [temporaryDirectory]
|
| ︙ | ︙ |
Changes to tests/macOSXLoad.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# Commands covered: load unload
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: load unload
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995 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::*
}
set oldTSF $::tcltest::testSingleFile
set ::tcltest::testSingleFile false
if {[testConstraint unix] && $tcl_platform(os) eq "Darwin" &&
![string match *pkga* [info loaded]]} {
|
| ︙ | ︙ |
Changes to tests/main.test.
1 2 | # This file contains a collection of tests for generic/tclMain.c. | > | < | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# This file contains a collection of tests for generic/tclMain.c.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
namespace eval ::tcl::test::main {
namespace import ::tcltest::*
# Is [exec] defined?
testConstraint exec [llength [info commands exec]]
|
| ︙ | ︙ |
Changes to tests/mathop.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# Commands covered: ::tcl::mathop::...
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 2006 Donal K. Fellows
# Copyright (c) 2006 Peter Spjuth
#
# 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: ::tcl::mathop::...
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 2006 Donal K. Fellows
# Copyright (c) 2006 Peter Spjuth
#
# 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::*
}
# A namespace to test that operators are exported and that they
# work when imported
namespace eval ::testmathop2 {
namespace import ::tcl::mathop::*
|
| ︙ | ︙ |
Changes to tests/misc.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 |
# Copyright (c) 1994-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]} {
| | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 1994-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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testhashsystemhash [llength [info commands testhashsystemhash]]
|
| ︙ | ︙ |
Changes to tests/msgcat.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Note that after running these tests, entries will be left behind in the # message catalogs for locales foo, foo_BAR, and foo_BAR_baz. | > | | < < | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Note that after running these tests, entries will be left behind in the
# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
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."
return
}
namespace eval ::msgcat::test {
|
| ︙ | ︙ |
Changes to tests/namespace-old.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 |
# Copyright (c) 1997 Lucent Technologies
# 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]} {
| | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# Copyright (c) 1997 Lucent Technologies
# 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::*
}
# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
test namespace-old-1.1 {usage for "namespace" command} {
|
| ︙ | ︙ |
Changes to tests/namespace.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. | > | | > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 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::*
}
testConstraint memory [llength [info commands memory]]
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
#
# REMARK: the tests for 'namespace upvar' are not done here. They are to be
|
| ︙ | ︙ | |||
175 176 177 178 179 180 181 |
namespace eval test_ns_2 {
proc x {} {}
trace add command x delete "namespace delete [namespace current];#"
}
namespace delete test_ns_2
} {}
test namespace-7.7 {Bug 1655305} -setup {
| | | | | | | | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
namespace eval test_ns_2 {
proc x {} {}
trace add command x delete "namespace delete [namespace current];#"
}
namespace delete test_ns_2
} {}
test namespace-7.7 {Bug 1655305} -setup {
interp create child
# Can't invoke through the ensemble, since deleting the global namespace
# (indirectly, via deleting ::tcl) deletes the ensemble.
child eval {rename ::tcl::info::commands ::infocommands}
child hide infocommands
child eval {
proc foo {} {
namespace delete ::
}
}
} -body {
child eval foo
child invokehidden infocommands
} -cleanup {
interp delete child
} -result {}
test namespace-7.8 {Bug ba1419303b4c} -setup {
namespace eval ns1 {
namespace ensemble create
}
|
| ︙ | ︙ | |||
265 266 267 268 269 270 271 |
proc p {} {return foo}
}
list [lsort [info commands test_ns_import::*]] \
[namespace delete test_ns_export] \
[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} {
| | | | | | | | | | | | | | | | 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
proc p {} {return foo}
}
list [lsort [info commands test_ns_import::*]] \
[namespace delete test_ns_export] \
[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 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
"child eval error foo bar baz"}
test namespace-8.6 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
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
"child eval error foo bar baz"}
test namespace-8.7 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
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
test namespace-9.1 {Tcl_Import, empty import pattern} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace eval test_ns_import {namespace import {}}} msg] $msg
} {1 {empty import pattern}}
|
| ︙ | ︙ | |||
2805 2806 2807 2808 2809 2810 2811 |
}
}
} -result 1_2 -cleanup {
namespace delete ::test_ns_1
namespace delete ::test_ns_2
}
test namespace-51.16 {Bug 1566526} {
| | | | | 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 |
}
}
} -result 1_2 -cleanup {
namespace delete ::test_ns_1
namespace delete ::test_ns_2
}
test namespace-51.16 {Bug 1566526} {
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 {}
catch {namespace delete ::a}
} -body {
namespace eval ::a {
proc c {} {lappend ::result A}
|
| ︙ | ︙ | |||
3008 3009 3010 3011 3012 3013 3014 |
rename ::unknown unknown.save
namespace eval :: {
proc unknown args {
return SUCCESS
}
}
catch {rename ::noSuchCommand {}}
| | | | | | | 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 |
rename ::unknown unknown.save
namespace eval :: {
proc unknown args {
return SUCCESS
}
}
catch {rename ::noSuchCommand {}}
set ::child [interp create]
} -body {
$::child alias bar noSuchCommand
namespace eval test_ns_1 {
namespace unknown unknown
proc unknown args {
return FAIL
}
$::child eval bar
}
} -cleanup {
interp delete $::child
unset ::child
namespace delete test_ns_1
rename ::unknown {}
rename unknown.save ::unknown
namespace eval :: [list namespace unknown $handler]
} -result SUCCESS
test namespace-52.12 {unknown: error case must not reset handler} -body {
namespace eval foo {
|
| ︙ | ︙ | |||
3381 3382 3383 3384 3385 3386 3387 |
} [namespace current]]]
trace add command ::ns2::p2 delete $ondelete
rename ns2::p2 {}
return $res
} -cleanup {
| | | 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 |
} [namespace current]]]
trace add command ::ns2::p2 delete $ondelete
rename ns2::p2 {}
return $res
} -cleanup {
unset res
namespace delete ns2
namespace delete ns3
} -result success
|
| ︙ | ︙ |
Changes to tests/notify.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 |
#
# Copyright (c) 2003 by Kevin B. Kenny. All rights reserved.
#
# 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]} {
| | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
#
# Copyright (c) 2003 by Kevin B. Kenny. All rights reserved.
#
# 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testevent [llength [info commands testevent]]
|
| ︙ | ︙ |
Changes to tests/nre.test.
1 2 3 4 5 6 7 8 9 10 11 12 |
# Commands covered: proc, apply, [interp alias], [namespce import]
#
# This file contains a collection of tests for the non-recursive executor that
# avoids recursive calls to TEBC. Only the NRE behaviour is tested here, the
# actual command functionality is tested in the specific test file.
#
# Copyright (c) 2008 by Miguel Sofer.
#
# 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: proc, apply, [interp alias], [namespce import]
#
# This file contains a collection of tests for the non-recursive executor that
# avoids recursive calls to TEBC. Only the NRE behaviour is tested here, the
# actual command functionality is tested in the specific test file.
#
# Copyright (c) 2008 by Miguel Sofer.
#
# 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testnrelevels [llength [info commands testnrelevels]]
|
| ︙ | ︙ |
Changes to tests/obj.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testobj [llength [info commands testobj]]
|
| ︙ | ︙ | |||
30 31 32 33 34 35 36 |
bytecode
cmdName
dict
regexp
string
} {
set first [string first $t [testobj types]]
| | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
bytecode
cmdName
dict
regexp
string
} {
set first [string first $t [testobj types]]
set r [expr {$r && ($first >= 0)}]
}
set result $r
} {1}
test obj-2.1 {Tcl_GetObjType error} testobj {
list [testintobj set 1 0] [catch {testobj convert 1 foo} msg] $msg
} {0 1 {no type foo found}}
|
| ︙ | ︙ |
Changes to tests/oo.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for Tcl's built-in object system. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright (c) 2006-2013 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require TclOO 1.0.3 | > | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# This file contains a collection of tests for Tcl's built-in object system.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2006-2013 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require TclOO 1.0.3
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# The foundational objects oo::object and oo::class are sensitive to reference
# counting errors and are deallocated only when an interp is deleted, so in
# this test suite, interp creation and interp deletion are often used in
# leaktests in order to leverage this sensitivity.
|
| ︙ | ︙ | |||
300 301 302 303 304 305 306 |
B create C
A destroy
}
} -cleanup {
rename test-oo-1.18 {}
} -result 0
test oo-1.18.3 {Bug 21c144f0f5} -setup {
| | | | | | | | | | | 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 |
B create C
A destroy
}
} -cleanup {
rename test-oo-1.18 {}
} -result 0
test oo-1.18.3 {Bug 21c144f0f5} -setup {
interp create child
} -body {
child eval {
oo::define [oo::class create foo] superclass oo::class
oo::class destroy
}
} -cleanup {
interp delete child
}
test oo-1.18.4 {correct handling of cleanup in superclass set error} -setup {
interp create child
} -body {
child eval {
oo::class create A
oo::class create B {
superclass oo::class
constructor {} {
next {superclass A}
next {superclass -append A}
}
}
[B create C] create d
}
} -returnCodes error -cleanup {
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 child
} -body {
child eval {
oo::class create A
oo::class create B {
superclass oo::class
constructor {c} {
next {superclass A}
next [list superclass -append {*}$c]
}
}
[B create C {B C}] create d
}
} -returnCodes error -cleanup {
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
namespace delete [info object namespace o]
o destroy
# Crashes on error
} -returnCodes error -result {invalid command name "o"}
|
| ︙ | ︙ | |||
1435 1436 1437 1438 1439 1440 1441 |
superclass foo
method bar {} {lappend ::result foo2; lappend ::result [next] foo2}
}
lappend result [catch {[foo2 new] bar} msg] $msg
} -result {foo2 foo 1 {no next method implementation}}
test oo-7.9 {OO: defining inheritance in namespaces} -setup {
set ::result {}
| | | | | | 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 |
superclass foo
method bar {} {lappend ::result foo2; lappend ::result [next] foo2}
}
lappend result [catch {[foo2 new] bar} msg] $msg
} -result {foo2 foo 1 {no next method implementation}}
test oo-7.9 {OO: defining inheritance in namespaces} -setup {
set ::result {}
oo::class create ::parent
namespace eval ::foo {
oo::class create mixin {superclass ::parent}
}
} -cleanup {
::parent destroy
namespace delete ::foo
} -body {
namespace eval ::foo {
oo::class create bar {superclass parent}
oo::class create boo
oo::define boo {superclass bar}
oo::define boo {mixin mixin}
oo::class create spong {superclass boo}
return
}
} -result {}
|
| ︙ | ︙ | |||
2131 2132 2133 2134 2135 2136 2137 |
oo::objdefine i method bar {} {return foobar}
i bar
} -cleanup {
c destroy
mix destroy
} -result >>foobar<<
test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup {
| | | | | | | | | | | | | | | | 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 |
oo::objdefine i method bar {} {return foobar}
i bar
} -cleanup {
c destroy
mix destroy
} -result >>foobar<<
test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create A {
superclass parent
method egg {} {
return chicken
}
}
oo::class create B {
superclass parent
mixin A
method bar {} {
# mixin from A
my egg
}
}
oo::class create C {
superclass parent
mixin B
method foo {} {
# mixin from B
my bar
}
}
[C new] foo
} -result chicken
test oo-14.7 {OO and filters from mixins of mixins} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create A {
superclass parent
method egg {} {
return chicken
}
filter f
method f args {
set m [lindex [self target] 1]
return "($m) [next {*}$args] ($m)"
}
}
oo::class create B {
superclass parent
mixin A
filter f
method bar {} {
# mixin from A
my egg
}
}
oo::class create C {
superclass parent
mixin B
filter f
method foo {} {
# mixin from B
my bar
}
}
[C new] foo
} -result {(foo) (bar) (egg) chicken (egg) (bar) (foo)}
test oo-14.8 {OO: class mixin order - Bug 1998221} -setup {
set ::result {}
oo::class create parent {
method test {} {}
}
} -cleanup {
parent destroy
} -body {
oo::class create mix {
superclass parent
method test {} {lappend ::result mix; next; return $::result}
}
oo::class create cls {
superclass parent
mixin mix
method test {} {lappend ::result cls; next; return $::result}
}
[cls new] test
} -result {mix cls}
test oo-15.1 {OO: object cloning} {
|
| ︙ | ︙ | |||
2911 2912 2913 2914 2915 2916 2917 |
} -result {1 foo {foo
while executing
"error foo"
(in definition script for object "::INST" line 1)
invoked from within
"oo::objdefine inst {rename ::inst ::INST;error foo}"}}
test oo-18.8 {OO: define/self command support} -setup {
| | | | | | | | | | | | | | 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 |
} -result {1 foo {foo
while executing
"error foo"
(in definition script for object "::INST" line 1)
invoked from within
"oo::objdefine inst {rename ::inst ::INST;error foo}"}}
test oo-18.8 {OO: define/self command support} -setup {
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 {
parent destroy
} -result {foobar
while executing
"error foobar"
(in definition script for class object "::bar" line 1)
invoked from within
"self {error foobar}"
(in definition script for class "::bar" line 1)
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 parent
set c [oo::class create now_this_is_a_very_very_long_class_name_indeed {
superclass parent
}]
} -body {
catch {oo::define $c {error err}} msg opt
dict get $opt -errorinfo
} -cleanup {
parent destroy
} -result {err
while executing
"error err"
(in definition script for class "::now_this_is_a_very_very_long..." line 1)
invoked from within
"oo::define $c {error err}"}
test oo-18.10 {OO: define/self command support} -setup {
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 {
parent destroy
} -result {foobar
while executing
"error foobar"
(in definition script for class object "::foo" line 1)
invoked from within
"self {rename ::foo {}; error foobar}"
(in definition script for class "::foo" line 1)
invoked from within
"oo::define foo {self {rename ::foo {}; error foobar}}"}
test oo-18.11 {OO: define/self command support} -setup {
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 {
parent destroy
} -result {this command cannot be called when the object has been deleted
while executing
"self {error foobar}"
(in definition script for class "::foo" line 1)
invoked from within
"oo::define foo {rename ::foo {}; self {error foobar}}"}
|
| ︙ | ︙ | |||
3590 3591 3592 3593 3594 3595 3596 |
} -cleanup {
foo destroy
} -body {
oo::objdefine foo variable a b c
info object variables foo
} -result {a b c}
test oo-27.3 {variables declaration - basic behaviour} -setup {
| | | | | | | | 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 |
} -cleanup {
foo destroy
} -body {
oo::objdefine foo variable a b c
info object variables foo
} -result {a b c}
test oo-27.3 {variables declaration - basic behaviour} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable x!
constructor {} {set x! 1}
method y {} {incr x!}
}
foo create bar
bar y
bar y
} -result 3
test oo-27.4 {variables declaration - destructors too} -setup {
oo::class create parent
set result bad!
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable x!
constructor {} {set x! 1}
method y {} {incr x!}
destructor {set ::result ${x!}}
}
foo create bar
bar y
|
| ︙ | ︙ | |||
3636 3637 3638 3639 3640 3641 3642 |
variable x!
method y {} {incr x!}
}
foo y
foo y
} -result 2
test oo-27.6 {variables declaration - non-interference of levels} -setup {
| | | | | | | | 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 |
variable x!
method y {} {incr x!}
}
foo y
foo y
} -result 2
test oo-27.6 {variables declaration - non-interference of levels} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable x!
constructor {} {set x! 1}
method y {} {incr x!}
}
foo create bar
oo::objdefine bar {
variable y!
method y {} {list [next] [incr y!] [info var] [info local]}
export eval
}
bar y
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 parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable x!
constructor {} {set x! 1}
method y {} {incr x!}
}
oo::class create foo2 {
superclass foo
variable y!
|
| ︙ | ︙ | |||
3688 3689 3690 3691 3692 3693 3694 |
test oo-27.8 {variables declaration - error cases - ns separators} -body {
oo::define oo::object variable bad::var
} -returnCodes error -result {invalid declared variable name "bad::var": must not contain namespace separators}
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 {
| | | | | 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 |
test oo-27.8 {variables declaration - error cases - ns separators} -body {
oo::define oo::object variable bad::var
} -returnCodes error -result {invalid declared variable name "bad::var": must not contain namespace separators}
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 parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable clsvar
constructor {} {
set clsvar 0
}
method step {} {
incr clsvar
return
|
| ︙ | ︙ | |||
3716 3717 3718 3719 3720 3721 3722 |
inst2 step
inst1 step
inst2 step
inst1 step
list [inst1 value] [inst2 value]
} -result {3 2}
test oo-27.11 {variables declaration - no instance var leaks with class resolvers} -setup {
| | | | | 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 |
inst2 step
inst1 step
inst2 step
inst1 step
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 parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable clsvar
constructor {} {
set clsvar 0
}
method step {} {
incr clsvar
return
|
| ︙ | ︙ | |||
3789 3790 3791 3792 3793 3794 3795 |
}
list [foo exists] [foo set 7] [foo exists] [foo get] [foo unset] \
[foo exists] [catch {foo get} msg] $msg
} -cleanup {
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 {
| | | | | | | | | | | | | | | | | 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 |
}
list [foo exists] [foo set 7] [foo exists] [foo get] [foo unset] \
[foo exists] [catch {foo get} msg] $msg
} -cleanup {
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 parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable x
variable y
method boo {} {
return [incr x],[incr y]
}
}
foo create bar
list [bar boo] [bar boo]
} -result {1,1 2,2}
test oo-27.15 {variables declaration - multiple use} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable
variable x y
method boo {} {
return [incr x],[incr y]
}
}
foo create bar
list [bar boo] [bar boo]
} -result {1,1 2,2}
test oo-27.16 {variables declaration - multiple use} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable x
variable -clear
variable y
method boo {} {
return [incr x],[incr y]
}
}
foo create bar
list [bar boo] [bar boo]
} -result {1,1 1,2}
test oo-27.17 {variables declaration - multiple use} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable x
variable -set y
method boo {} {
return [incr x],[incr y]
}
}
foo create bar
list [bar boo] [bar boo]
} -result {1,1 1,2}
test oo-27.18 {variables declaration - multiple use} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable x
variable -? y
method boo {} {
return [incr x],[incr y]
}
}
foo create bar
|
| ︙ | ︙ | |||
3957 3958 3959 3960 3961 3962 3963 |
oo::objdefine foo variable v v v t t v t
info object variable foo
} -cleanup {
foo destroy
} -result {v t}
test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup {
oo::class create Super
| | | | | | | 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 |
oo::objdefine foo variable v v v t t v t
info object variable foo
} -cleanup {
foo destroy
} -result {v t}
test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup {
oo::class create Super
oo::class create Parent {
superclass Super
variable member1 member2
constructor {} {
set member1 parent1
set member2 parent2
}
method getChild {} {
Child new [self]
}
}
oo::class create Child {
superclass Super
variable member1 result
constructor {m} {
set [namespace current]::member1 child1
set ns [info object namespace $m]
namespace upvar $ns member1 l1 member2 l2
upvar 1 member1 l3 member2 l4
[format namespace] upvar $ns member1 l5 member2 l6
[format upvar] 1 member1 l7 member2 l8
set result [list $l1 $l2 $l3 $l4 $l5 $l6 $l7 $l8]
}
method result {} {return $result}
}
} -body {
[[Parent new] getChild] result
} -cleanup {
Super destroy
} -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...
test oo-28.1 {scripted extensions to oo::define} -setup {
interp create foo
foo eval {oo::class create cls {export eval}}
} -cleanup {
|
| ︙ | ︙ |
Changes to tests/ooNext2.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for Tcl's built-in object system. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright (c) 2006-2011 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require TclOO 1.0.3 | > | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# This file contains a collection of tests for Tcl's built-in object system.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2006-2011 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require TclOO 1.0.3
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
set lines [split [memory info] \n]
|
| ︙ | ︙ | |||
878 879 880 881 882 883 884 |
# subclass was not there.
# Common setup:
# any invocation of bar should emit "abc\nhi\n" then return to its
# caller
set testopts {
-setup {
| | | | | | 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 |
# subclass was not there.
# Common setup:
# any invocation of bar should emit "abc\nhi\n" then return to its
# caller
set testopts {
-setup {
oo::class create Parent
oo::class create Foo {
superclass Parent
method bar {} {
puts abc
tailcall puts hi
puts xyz
}
}
oo::class create Foo2 {
superclass Parent
}
}
-cleanup {
Parent destroy
}
}
# these succeed, showing that without [next] the bug doesn't fire
test next-tailcall-simple-1 "trivial case with one method" {*}$testopts -body {
[Foo create foo] bar
} -output [join {abc hi} \n]\n
|
| ︙ | ︙ |
Changes to tests/ooUtil.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file contains a collection of tests for functionality originally # sourced from the ooutil package in Tcllib. Sourcing this file into Tcl runs # the tests and generates output for errors. No output means no errors were # found. # # Copyright (c) 2014-2016 Andreas Kupries # Copyright (c) 2018 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require TclOO 1.0.3 | > | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# This file contains a collection of tests for functionality originally
# sourced from the ooutil package in Tcllib. Sourcing this file into Tcl runs
# the tests and generates output for errors. No output means no errors were
# found.
#
# Copyright (c) 2014-2016 Andreas Kupries
# Copyright (c) 2018 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require TclOO 1.0.3
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test ooUtil-1.1 {TIP 478: classmethod} -setup {
oo::class create parent
} -body {
oo::class create ActiveRecord {
|
| ︙ | ︙ | |||
149 150 151 152 153 154 155 |
classmethod find args {
return "[self] called with arguments: $args"
}
}
oo::class create Table {
superclass ActiveRecord
}
| | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 |
classmethod find args {
return "[self] called with arguments: $args"
}
}
oo::class create Table {
superclass ActiveRecord
}
# This is confirming that this is not the parent interpreter
list [Table find foo bar] [info globals childinterp]
}
} -cleanup {
interp delete $childinterp
} -result {{::Table called with arguments: foo bar} {}}
test ooUtil-1.9 {TIP 478: classmethod in safe child interp} -setup {
set safeinterp [interp create -safe]
|
| ︙ | ︙ |
Changes to tests/opt.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994-1997 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]} {
| | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# Copyright (c) 1994-1997 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::*
}
# the package we are going to test
package require opt 0.4.8
# we are using implementation specifics to test the package
#### functions tests #####
set n $::tcl::OptDescN
|
| ︙ | ︙ |
Changes to tests/package.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 |
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2011 Donal K. Fellows
#
# 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]} {
| | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2011 Donal K. Fellows
#
# 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Do all this in a child interp to avoid garbaging the package list
|
| ︙ | ︙ |
Changes to tests/parse.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for the procedures in the # file tclParse.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 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. | > | < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# This file contains a collection of tests for the procedures in the
# file tclParse.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 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::*
}
namespace eval ::tcl::test::parse {
namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
|
| ︙ | ︙ | |||
401 402 403 404 405 406 407 |
set ::info
} {1 1}
test parse-8.11 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} testevalobjv {
rename ::unknown unknown.save
proc ::unknown args {lappend ::info [info level]; uplevel 1 foo}
proc ::foo args {lappend ::info global}
catch {rename ::noSuchCommand {}}
| | | | | | | | | | | 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 |
set ::info
} {1 1}
test parse-8.11 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} testevalobjv {
rename ::unknown unknown.save
proc ::unknown args {lappend ::info [info level]; uplevel 1 foo}
proc ::foo args {lappend ::info global}
catch {rename ::noSuchCommand {}}
set ::child [interp create]
$::child alias bar noSuchCommand
set ::info {}
namespace eval test_ns_1 {
proc foo args {lappend ::info namespace}
$::child eval bar
testevalobjv 1 [list $::child eval bar]
uplevel #0 [list $::child eval bar]
}
namespace delete test_ns_1
rename ::foo {}
rename ::unknown {}
rename unknown.save ::unknown
set ::info
} [subst {[set level 2; incr level [info level]] global 1 global 1 global}]
test parse-8.12 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} {
set ::auto_index(noSuchCommand) {
proc noSuchCommand {} {lappend ::info global}
}
set ::auto_index(::[string trimleft [namespace current]::test_ns_1::noSuchCommand :]) [list \
proc [namespace current]::test_ns_1::noSuchCommand {} {
lappend ::info ns
}]
catch {rename ::noSuchCommand {}}
set ::child [interp create]
$::child alias bar noSuchCommand
set ::info {}
namespace eval test_ns_1 {
$::child eval bar
}
namespace delete test_ns_1
interp delete $::child
catch {rename ::noSuchCommand {}}
set ::info
} global
test parse-9.1 {Tcl_LogCommandInfo, line numbers} testevalex {
unset -nocomplain x
|
| ︙ | ︙ |
Changes to tests/parseExpr.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for the procedures in the # file tclCompExpr.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 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. | > | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# This file contains a collection of tests for the procedures in the
# file tclCompExpr.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Note that the Tcl expression parser (tclCompExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
# for example, that a math function actually exists, or that the operands
|
| ︙ | ︙ |
Changes to tests/parseOld.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-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. | > | | > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testwordend [llength [info commands testwordend]]
testConstraint testbytestring [llength [info commands testbytestring]]
|
| ︙ | ︙ |
Changes to tests/pid.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994-1995 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994-1995 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::*
}
testConstraint pidDefined [llength [info commands pid]]
test pid-1.1 {pid command} pidDefined {
regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
|
| ︙ | ︙ |
Changes to tests/pkgMkIndex.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains tests for the pkg_mkIndex command. # Note that the tests are limited to Tcl scripts only, there are no shared # libraries against which to test. # # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. | > | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# This file contains tests for the pkg_mkIndex command.
# Note that the tests are limited to Tcl scripts only, there are no shared
# libraries against which to test.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
set fullPkgPath [makeDirectory pkg]
namespace eval pkgtest {
# Namespace for procs we can discard
}
|
| ︙ | ︙ | |||
68 69 70 71 72 73 74 |
#
# Results:
# Returns a list, in "array set/get" format, where the keys are the package
# name and version (in the form "$name:$version"), and the values the rest
# of the command line.
proc pkgtest::parseIndex { filePath } {
| | | | | | | | | | | | | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 |
#
# Results:
# Returns a list, in "array set/get" format, where the keys are the package
# name and version (in the form "$name:$version"), and the values the rest
# of the command line.
proc pkgtest::parseIndex { filePath } {
# create a child interpreter, where we override "package ifneeded"
set child [interp create]
if {[catch {
$child eval {
rename package package_original
proc package { args } {
if {[lindex $args 0] eq "ifneeded"} {
set pkg [lindex $args 1]
set ver [lindex $args 2]
set ::PKGS($pkg:$ver) [lindex $args 3]
} else {
return [package_original {*}$args]
}
}
array set ::PKGS {}
}
set dir [file dirname $filePath]
$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} [$child eval {array get ::PKGS}] {
set P($k) $v
}
set PKGS ""
foreach k [lsort [array names P]] {
lappend PKGS $k $P($k)
}
} err opts]} {
set ei [dict get $opts -errorinfo]
set ec [dict get $opts -errorcode]
catch {interp delete $child}
error $ei $ec
}
interp delete $child
return $PKGS
}
# pkgtest::createIndex --
#
# Runs pkg_mkIndex for the given directory and set of patterns. This
|
| ︙ | ︙ |
Changes to tests/platform.test.
1 2 3 4 5 6 7 8 9 10 11 | # The file tests the tcl_platform variable and platform package. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 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. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# The file tests the tcl_platform variable and platform package.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 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 tcltest 2.5
namespace eval ::tcl::test::platform {
namespace import ::tcltest::testConstraint
namespace import ::tcltest::test
namespace import ::tcltest::cleanupTests
# This is not how [variable] works. See TIP 276.
|
| ︙ | ︙ |
Changes to tests/proc-old.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 |
# Copyright (c) 1994-1997 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]} {
| | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# Copyright (c) 1994-1997 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::*
}
catch {rename t1 ""}
catch {rename foo ""}
proc tproc {} {return a; return b}
|
| ︙ | ︙ |
Changes to tests/proc.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 |
# Copyright (c) 1997 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]} {
| | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright (c) 1997 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::*
}
testConstraint procbodytest [expr {![catch {package require procbodytest}]}]
testConstraint memory [llength [info commands memory]]
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
| ︙ | ︙ | |||
385 386 387 388 389 390 391 |
} -cleanup {
namespace delete ugly
} -result 4
test proc-7.4 {Proc struct outlives its interp: Bug 3532959} {
set lambda x
lappend lambda {set a 1}
| | | | | 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 |
} -cleanup {
namespace delete ugly
} -result 4
test proc-7.4 {Proc struct outlives its interp: Bug 3532959} {
set lambda x
lappend lambda {set a 1}
interp create child
child eval [list apply $lambda foo]
interp delete child
unset lambda
} {}
test proc-7.5 {[631b4c45df] Crash in argument processing} {
binary scan A c val
proc foo [list [list from $val]] {}
rename foo {}
|
| ︙ | ︙ |
Changes to tests/process.test.
1 2 3 4 5 6 7 8 9 10 11 |
# process.test --
#
# This file contains a collection of tests for the tcl::process ensemble.
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 2017 Frederic Bonnet
# 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# process.test --
#
# This file contains a collection of tests for the tcl::process ensemble.
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 2017 Frederic Bonnet
# 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::*
}
# Utilities
file delete [set path(test-signalfile) [makeFile {} test-signalfile]]
set path(test-signalfile2) [makeFile {} test-signalfile2]
# $path(sleep) time ?filename? -- sleep for time (in ms) and stop if it gets signaled (file gets deleted)
|
| ︙ | ︙ |
Changes to tests/pwd.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994-1997 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994-1997 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::*
}
test pwd-1.1 {simple pwd} {
catch pwd
} 0
test pwd-1.2 {simple pwd} {
|
| ︙ | ︙ |
Changes to tests/reg.test.
1 2 3 4 5 6 7 8 9 10 11 12 |
# reg.test --
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
# (Don't panic if you are seeing this as part of the reg distribution
# and aren't using Tcl -- reg's own regression tester also knows how
# to read this file, ignoring the Tcl-isms.)
#
# Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
if {"::tcltest" ni [namespace children]} {
| | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# reg.test --
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
# (Don't panic if you are seeing this as part of the reg distribution
# and aren't using Tcl -- reg's own regression tester also knows how
# to read this file, ignoring the Tcl-isms.)
#
# Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# All tests require the testregexp command, return if this
# command doesn't exist
|
| ︙ | ︙ | |||
283 284 285 286 287 288 289 |
set constraints [TestConstraints $flags]
set f [TestFlags $flags]
set infoflags [TestInfoFlags $flags]
set ccmd [list testregexp -about {*}$f $re]
set nsub [expr {[llength $args] - 1}]
| | | 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 |
set constraints [TestConstraints $flags]
set f [TestFlags $flags]
set infoflags [TestInfoFlags $flags]
set ccmd [list testregexp -about {*}$f $re]
set nsub [expr {[llength $args] - 1}]
if {$nsub < 0} {
# didn't tell us number of subexps
set ccmd "lreplace \[$ccmd\] 0 0"
set info [list $infoflags]
} else {
set info [list $nsub $infoflags]
}
set ecmd [list testregexp {*}$f $re $target]
|
| ︙ | ︙ |
Changes to tests/regexp.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1998 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1998 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::*
}
unset -nocomplain foo
testConstraint exec [llength [info commands exec]]
|
| ︙ | ︙ | |||
188 189 190 191 192 193 194 195 196 197 198 199 200 201 |
set foo 2; set f2 2; set f3 2; set f4 2
list [regexp -indices (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4
} {1 {1 1} {1 1} {-1 -1} {-1 -1}}
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-4.1 {-nocase option to regexp} {
regexp -nocase foo abcFOo
} 1
test regexp-4.2 {-nocase option to regexp} {
set f1 22
set f2 33
| > > > > > > > > > > > | 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 |
set foo 2; set f2 2; set f3 2; set f4 2
list [regexp -indices (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4
} {1 {1 1} {1 1} {-1 -1} {-1 -1}}
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
} 1
test regexp-4.2 {-nocase option to regexp} {
set f1 22
set f2 33
|
| ︙ | ︙ |
Changes to tests/regexpComp.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1998 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1998 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::*
}
# Procedure to evaluate a script within a proc, to test compilation
# functionality
proc evalInProc { script } {
|
| ︙ | ︙ |
Changes to tests/registry.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# registry.test --
#
# This file contains a collection of tests for the registry command.
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# In order for these tests to run, the registry package must be on the
# auto_path or the registry package must have been loaded already.
#
# Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved.
# Copyright (c) 1998-1999 by Scriptics Corporation.
if {"::tcltest" ni [namespace children]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# registry.test --
#
# This file contains a collection of tests for the registry command.
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# In order for these tests to run, the registry package must be on the
# auto_path or the registry package must have been loaded already.
#
# Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved.
# Copyright (c) 1998-1999 by Scriptics Corporation.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint reg 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
Changes to tests/rename.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testdel [llength [info commands testdel]]
|
| ︙ | ︙ |
Changes to tests/resolver.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This test collection covers some unwanted interactions between command # literal sharing and the use of command resolvers (per-interp) which cause # command literals to be re-used with their command references being invalid # in the reusing context. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2011 Gustaf Neumann <gustaf.neumann@wu.ac.at> # Copyright (c) 2011 Stefan Sobernig <stefan.sobernig@wu.ac.at> # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. | > | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# This test collection covers some unwanted interactions between command
# literal sharing and the use of command resolvers (per-interp) which cause
# command literals to be re-used with their command references being invalid
# in the reusing context. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 2011 Gustaf Neumann <gustaf.neumann@wu.ac.at>
# Copyright (c) 2011 Stefan Sobernig <stefan.sobernig@wu.ac.at>
#
# 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testinterpresolver [llength [info commands testinterpresolver]]
|
| ︙ | ︙ | |||
199 200 201 202 203 204 205 | # The test resolver-3.1* test bad interactions of resolvers on the "global" # (per interp) literal pools. A resolver might resolve a cmd literal depending # on a context differently, whereas the cmd literal sharing assumed that the # namespace containing the literal solely determines the resolved cmd (and is # resolver-agnostic). # # In order to make the test cases for the per-interpreter cmd literal pool | | | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 |
# The test resolver-3.1* test bad interactions of resolvers on the "global"
# (per interp) literal pools. A resolver might resolve a cmd literal depending
# on a context differently, whereas the cmd literal sharing assumed that the
# namespace containing the literal solely determines the resolved cmd (and is
# 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 child
# interpreter per test-case.
#
#
# Testing resolver in namespace-based context "ctx1"
#
test resolver-3.1a {
interp command resolver,
|
| ︙ | ︙ |
Changes to tests/result.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file tests the routines in tclResult.c. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by 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. | > | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# This file tests the routines in tclResult.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Some tests require the testsaveresult command
testConstraint testsaveresult [llength [info commands testsaveresult]]
|
| ︙ | ︙ |
Added tests/safe-stock.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 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:
|
Added tests/safe-zipfs.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 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:
|
Changes to tests/safe.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # safe.test -- # # This file contains a collection of tests for safe Tcl, packages loading, and # using safe interpreters. 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. | > > > > > > > > > > < < | | | > > > > > > > > > > > > > > > > > | | | | | | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
# safe.test --
#
# This file contains a collection of tests for safe Tcl, packages loading, and
# 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-stock87.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.
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 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
# 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}]}]
test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body {
safe::interpConfigure
} -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)
?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
-nested boolean (false) nested loading
-deleteHook script () delete hook}
test safe-1.3 {safe::interpInit syntax} -returnCodes error -body {
safe::interpInit -noStatics
} -result {bad value "-noStatics" for parameter
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]
# interp aliases
} ""
test safe-2.2 {creating interpreters, should have no aliases} -setup {
catch {safe::interpDelete a}
} -body {
interp create a
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}
} -body {
interp create a -safe
lsort [a aliases]
} -cleanup {
|
| ︙ | ︙ | |||
111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 |
} -result {}
test safe-4.1 {safe::interpDelete} -setup {
catch {safe::interpDelete a}
} -body {
interp create a
safe::interpDelete a
} -result ""
test safe-4.2 {safe::interpDelete, indirectly} -setup {
catch {safe::interpDelete a}
} -body {
interp create a
a alias exit safe::interpDelete a
a eval exit
} -result ""
test safe-4.5 {safe::interpDelete} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
safe::interpCreate a
} -returnCodes error -cleanup {
safe::interpDelete a
} -result {interpreter named "a" already exists, cannot create}
test safe-4.6 {safe::interpDelete, indirectly} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
a eval exit
} -result ""
| > > > > > > > | > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < > > > | > > > > > > | > > > > > > > > > > > > < > > > > > > > > > > > > | > | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 |
} -result {}
test safe-4.1 {safe::interpDelete} -setup {
catch {safe::interpDelete a}
} -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}
} -body {
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}
} -body {
safe::interpCreate a
safe::interpCreate a
} -returnCodes error -cleanup {
safe::interpDelete a
} -result {interpreter named "a" already exists, cannot create}
test safe-4.6 {safe::interpDelete, indirectly} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
a eval exit
} -result ""
# The old test "safe-5.1" has been moved to "safe-stock87-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 {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 {
# 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-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} {
# Helper procedure that ensures the safe interp is cleaned up even if
# there is a failure in the script.
set SafeInterp [interp create -safe]
catch {$SafeInterp eval $script} msg opts
|
| ︙ | ︙ | |||
172 173 174 175 176 177 178 179 180 181 182 |
if {[testConstraint win]} {
set r [lsearch -all -inline -not -exact $r "debug"]
}
set r [lsearch -all -inline -not -exact $r "threaded"]
lsort $r
} {byteOrder engine pathSeparator platform pointerSize wordSize}
# More test should be added to check that hostname, nameofexecutable, aren't
# leaking infos, but they still do...
# high level general test
| > > | > > > > | | | < > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | > | | < | | | | | | < < > > > > > < > > | > < > > | > < > > | > < > > | > < > > | > > > > < > > > > > > > | | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 |
if {[testConstraint win]} {
set r [lsearch -all -inline -not -exact $r "debug"]
}
set r [lsearch -all -inline -not -exact $r "threaded"]
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
# 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 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-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 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 $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 $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 $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
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}
set prevlog [safe::setLogCmd]
} -body {
safe::interpCreate $i
safe::setLogCmd safe-test-log
list [catch {$i eval {source .}} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
safe::interpDelete $i
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}
set prevlog [safe::setLogCmd]
} -body {
safe::interpCreate $i
safe::setLogCmd safe-test-log
list [catch {$i eval {source /abc/def}} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
safe::interpDelete $i
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}
set prevlog [safe::setLogCmd]
} -body {
# This tested filename == *.tcl or tclIndex, but that restriction was
# removed in 8.4a4 - hobbs
safe::interpCreate $i
safe::setLogCmd safe-test-log
list [catch {
$i eval {source [file join [info lib] blah]}
} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
safe::interpDelete $i
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}
set prevlog [safe::setLogCmd]
} -body {
safe::interpCreate $i
safe::setLogCmd safe-test-log
list [catch {
$i eval {source [file join [info lib] blah.tcl]}
} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
safe::interpDelete $i
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}
set prevlog [safe::setLogCmd]
} -body {
safe::interpCreate $i
# This tested length of filename, but that restriction was removed in
# 8.4a4 - hobbs
safe::setLogCmd safe-test-log
list [catch {
$i eval {source [file join [info lib] xxxxxxxxxxx.tcl]}
} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
safe::interpDelete $i
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 {
safe::interpCreate $i
set token [safe::interpAddToAccessPath $i [file dirname $returnScript]]
$i eval [list source $token/[file tail $returnScript]]
} -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 {
safe::interpCreate $i
set token [safe::interpAddToAccessPath $i [file dirname $returnScript]]
$i eval [list apply {filename {
source $filename
error boom
}} $token/[file tail $returnScript]]
} -cleanup {
catch {safe::interpDelete $i}
removeFile $returnScript
unset i
} -result ok
test safe-9.1 {safe interps' deleteHook} -setup {
set i "a"
catch {safe::interpDelete $i}
set res {}
} -body {
proc testDelHook {args} {
global res
# the interp still exists at that point
interp eval a {set delete 1}
# mark that we've been here (successfully)
set res $args
}
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 {}
proc safe-test-log {str} {lappend ::log $str}
set prevlog [safe::setLogCmd]
} -body {
proc testDelHook {args} {
global res
# the interp still exists at that point
interp eval a {set delete 1}
# mark that we've been here (successfully)
set res $args
# create an exception
error "being catched"
}
safe::interpCreate $i -deleteHook "testDelHook arg1 arg2"
safe::setLogCmd safe-test-log
list [safe::interpDelete $i] $res $log
} -cleanup {
safe::setLogCmd $prevlog
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}
test safe-9.4 {dual specification of statics} {
# no error shall occur
safe::interpDelete [safe::interpCreate -stat false -nostat]
} {}
|
| ︙ | ︙ | |||
399 400 401 402 403 404 405 | [safe::interpConfigure $i -nested]\ [safe::interpConfigure $i -statics]\ [safe::interpConfigure $i -DEL]\ [safe::interpConfigure $i -accessPath /blah -statics 1 safe::interpConfigure $i]\ [safe::interpConfigure $i -deleteHook toto -nosta -nested 0 safe::interpConfigure $i] | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 |
[safe::interpConfigure $i -nested]\
[safe::interpConfigure $i -statics]\
[safe::interpConfigure $i -DEL]\
[safe::interpConfigure $i -accessPath /blah -statics 1
safe::interpConfigure $i]\
[safe::interpConfigure $i -deleteHook toto -nosta -nested 0
safe::interpConfigure $i]
} -cleanup {
safe::interpDelete $i
} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\
{-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\
{-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\
{-accessPath * -statics 0 -nested 0 -deleteHook toto}}
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 {
set i [safe::interpCreate]
} -body {
interp eval $i {load {} Safepkg1}
} -returnCodes error -cleanup {
safe::interpDelete $i
} -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 {
catch {interp eval $i {load {} Safepkg1}} m o
dict get $o -errorinfo
} -returnCodes ok -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -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
"interp eval $i {load {} Safepkg1}"}
test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body {
set i [safe::interpCreate -nostatics]
interp eval $i {load {} Safepkg1}
|
| ︙ | ︙ | |||
440 441 442 443 444 445 446 |
safe::interpDelete $i
} -result {permission denied (nested load)}
test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body {
set i [safe::interpCreate -nestedloadok]
interp eval $i {interp create x; load {} Safepkg1 x}
} -returnCodes error -cleanup {
safe::interpDelete $i
| | | | 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 |
safe::interpDelete $i
} -result {permission denied (nested load)}
test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body {
set i [safe::interpCreate -nestedloadok]
interp eval $i {interp create x; load {} Safepkg1 x}
} -returnCodes error -cleanup {
safe::interpDelete $i
} -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
dict get $o -errorinfo
} -returnCodes ok -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -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
"interp eval $i {interp create x; load {} Safepkg1 x}"}
test safe-11.1 {testing safe encoding} -setup {
set i [safe::interpCreate]
|
| ︙ | ︙ | |||
604 605 606 607 608 609 610 611 612 613 614 615 616 617 |
proc buildEnvironment {filename} {
upvar 1 testdir testdir testdir2 testdir2 testfile testfile
set testdir [makeDirectory deletethisdir]
set testdir2 [makeDirectory deletemetoo $testdir]
set testfile [makeFile {} $filename $testdir2]
}
#### New tests for Safe base glob, with patches @ Bug 2964715
test safe-13.1 {glob is restricted [Bug 2964715]} -setup {
set i [safe::interpCreate]
} -body {
$i eval glob *
} -returnCodes error -cleanup {
safe::interpDelete $i
| > > > > > > > > > | 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 |
proc buildEnvironment {filename} {
upvar 1 testdir testdir testdir2 testdir2 testfile testfile
set testdir [makeDirectory deletethisdir]
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]
} -body {
$i eval glob *
} -returnCodes error -cleanup {
safe::interpDelete $i
|
| ︙ | ︙ | |||
675 676 677 678 679 680 681 |
::safe::interpAddToAccessPath $i $testdir
$i eval \
glob -nocomplain -directory $testdir [file join deletemetoo *.tm]
} -cleanup {
safe::interpDelete $i
removeDirectory $testdir
} -result {}
| | | > > > > > > > > > > > > > | | < | | 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 |
::safe::interpAddToAccessPath $i $testdir
$i eval \
glob -nocomplain -directory $testdir [file join deletemetoo *.tm]
} -cleanup {
safe::interpDelete $i
removeDirectory $testdir
} -result {}
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
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/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 {
set safeTD [::safe::interpAddToAccessPath $i $testdir]
::safe::interpAddToAccessPath $i $testdir2
$i eval [list glob -directory $safeTD -join -nocomplain * notIndex.tcl]
} -cleanup {
|
| ︙ | ︙ | |||
727 728 729 730 731 732 733 734 735 |
::safe::interpAddToAccessPath $i $testdir
$i eval glob -directory $testdir -join -nocomplain * notIndex.tcl
} -cleanup {
safe::interpDelete $i
removeDirectory $testdir
} -result {}
rename buildEnvironment {}
#### Test for the module path
| > | | 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 |
::safe::interpAddToAccessPath $i $testdir
$i eval glob -directory $testdir -join -nocomplain * notIndex.tcl
} -cleanup {
safe::interpDelete $i
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 parent interpreter [Bug 2964715]} -setup {
set i [safe::interpCreate]
} -body {
set tm {}
foreach token [$i eval ::tcl::tm::path list] {
lappend tm [dict get [set ::safe::S${i}(access_path,map)] $token]
}
return $tm
|
| ︙ | ︙ | |||
791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 |
$i eval {
set d [format %c 126]
list [file join [file dirname $d] [file tail $d]]
}
} -cleanup {
safe::interpDelete $i
set env(HOME) $savedHOME
} -result {./~}
test safe-16.2 {Bug 3529949: defang ~user in paths} -setup {
set i [safe::interpCreate]
set user $tcl_platform(user)
} -body {
string map [list $user USER] [$i eval \
"file join \[file dirname ~$user\] \[file tail ~$user\]"]
} -cleanup {
safe::interpDelete $i
} -result {./~USER}
test safe-16.3 {Bug 3529949: defang ~ in globs} -setup {
set syntheticHOME [makeDirectory foo]
makeFile {} bar $syntheticHOME
set savedHOME $env(HOME)
set env(HOME) $syntheticHOME
set i [safe::interpCreate]
} -body {
::safe::interpAddToAccessPath $i $syntheticHOME
$i eval {glob -nocomplain ~/*}
} -cleanup {
safe::interpDelete $i
set env(HOME) $savedHOME
removeDirectory $syntheticHOME
} -result {}
test safe-16.4 {Bug 3529949: defang ~user in globs} -setup {
set i [safe::interpCreate]
} -body {
::safe::interpAddToAccessPath $i $~$tcl_platform(user)
$i eval [list glob -nocomplain ~$tcl_platform(user)/*]
} -cleanup {
safe::interpDelete $i
} -result {}
| > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > | 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 |
$i eval {
set d [format %c 126]
list [file join [file dirname $d] [file tail $d]]
}
} -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]
set user $tcl_platform(user)
} -body {
string map [list $user USER] [$i eval \
"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]
makeFile {} bar $syntheticHOME
set savedHOME $env(HOME)
set env(HOME) $syntheticHOME
set i [safe::interpCreate]
} -body {
::safe::interpAddToAccessPath $i $syntheticHOME
$i eval {glob -nocomplain ~/*}
} -cleanup {
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]
} -body {
::safe::interpAddToAccessPath $i $~$tcl_platform(user)
$i eval [list glob -nocomplain ~$tcl_platform(user)/*]
} -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}
# cleanup
set ::auto_path $SaveAutoPath
unset SaveAutoPath TestsDir PathMapp
rename mapList {}
rename mapAndSortList {}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/scan.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994-1997 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994-1997 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::*
}
# procedure that returns the range of integers
proc int_range {} {
set MAX_INT [expr {[format %u -2]/2}]
|
| ︙ | ︙ |
Changes to tests/security.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# security.test --
#
# Functionality covered: this file contains a collection of tests for the auto
# loading and namespaces.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
if {"::tcltest" ni [namespace children]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# security.test --
#
# Functionality covered: this file contains a collection of tests for the auto
# loading and namespaces.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# If this proc becomes invoked, then there is a bug
proc BUG {args} {
set ::BUG 1
|
| ︙ | ︙ |
Changes to tests/set-old.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 |
# Copyright (c) 1994-1997 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]} {
| | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright (c) 1994-1997 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::*
}
proc ignore args {}
# Simple variable operations.
|
| ︙ | ︙ |
Changes to tests/set.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# Commands covered: set
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: set
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testset2 [llength [info commands testset2]]
|
| ︙ | ︙ |
Changes to tests/socket.test.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
# the server. If the connection is successful, the tests using the remote
# server will be performed; otherwise, it will attempt to start the remote
# server (via exec) on platforms that support this, on the local host,
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.
if {"::tcltest" ni [namespace children]} {
| | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
# the server. If the connection is successful, the tests using the remote
# server will be performed; otherwise, it will attempt to start the remote
# server (via exec) on platforms that support this, on the local host,
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
::tcltest::loadTestedCommands
|
| ︙ | ︙ | |||
244 245 246 247 248 249 250 |
}
}
}
# Some tests are run only if we are doing testing against a remote server.
testConstraint doTestsWithRemoteServer $doTestsWithRemoteServer
if {!$doTestsWithRemoteServer} {
| | | 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 |
}
}
}
# 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] >= 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"
}
}
#
|
| ︙ | ︙ | |||
287 288 289 290 291 292 293 294 295 296 297 298 299 300 |
}
}
proc getPort sock {
lindex [fconfigure $sock -sockname] 2
}
# ----------------------------------------------------------------------
test socket_$af-1.1 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -server
} -returnCodes error -result {no argument given for -server option}
test socket_$af-1.2 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
| > > > | 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 |
}
}
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"}]
# ----------------------------------------------------------------------
test socket_$af-1.1 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -server
} -returnCodes error -result {no argument given for -server option}
test socket_$af-1.2 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
|
| ︙ | ︙ | |||
1860 1861 1862 1863 1864 1865 1866 |
set srvsock [socket -server {apply {{ch args} {close $ch}}} -myaddr $::localhost $port]
# socket on windows has some issues yet (e. g. bug [b6d0d8cc2c]), so we simply decrease iteration count (to 1/4):
if {$::tcl_platform(platform) eq "windows" && $maxIter > 50} {
set ::count [expr {$maxIter / 4 * 3 - 1}]; # bypass 3/4 iterations
}
}
tcltest::DebugPuts 1 "== test \[$::localhost\]:$port $testmode =="
| | | | | | | | | | | | | 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 |
set srvsock [socket -server {apply {{ch args} {close $ch}}} -myaddr $::localhost $port]
# socket on windows has some issues yet (e. g. bug [b6d0d8cc2c]), so we simply decrease iteration count (to 1/4):
if {$::tcl_platform(platform) eq "windows" && $maxIter > 50} {
set ::count [expr {$maxIter / 4 * 3 - 1}]; # bypass 3/4 iterations
}
}
tcltest::DebugPuts 1 "== test \[$::localhost\]:$port $testmode =="
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 $::parent $::localhost $port $testmode] \
::parent ::localhost ::port ::testmode
]
thread::send -async $::helper {
set ::helper [thread::id]
proc iteration {args} {
set fd [socket -async $::localhost $::port]
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 $::parent {set ::count "ERROR: invalid thread, $::helper is expecting"}
close $fd
return
}
}} $fd]
};#
thread::detach $fd
thread::send -async $::parent [list transf_parent $fd {*}$args]
}
iteration first
}
# 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 {"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 $::parent} {
thread::send -async $::parent {set ::count "ERROR: invalid thread, $::parent is expecting"}
close $fd
return
}
set ::count $::count
close $fd
}} $fd]
}
|
| ︙ | ︙ | |||
1924 1925 1926 1927 1928 1929 1930 |
update
set ::count
} finally {
catch {after cancel $tout}
if {$srvsock ne {}} {close $srvsock}
if {[info exists ::helper]} {thread::release -wait $::helper}
tcltest::DebugPuts 1 "== stop / $::count =="
| | | | | | 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 |
update
set ::count
} finally {
catch {after cancel $tout}
if {$srvsock ne {}} {close $srvsock}
if {[info exists ::helper]} {thread::release -wait $::helper}
tcltest::DebugPuts 1 "== stop / $::count =="
unset -nocomplain ::count ::testmode ::parent ::helper
}
}
test socket_$af-13.2.tr1 {Testing socket transfer between threads during async connect} -body {
transf_test {transfer} 1000
} -result 1000 -constraints [list socket supported_$af thread]
test socket_$af-13.2.tr2 {Testing socket transfer between threads during async connect} -body {
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 {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 {parent-close helper-writable} 100
} -result 100 -constraints [list socket supported_$af thread]
catch {rename transf_parent {}}
rename transf_test {}
# ----------------------------------------------------------------------
removeFile script1
removeFile script2
|
| ︙ | ︙ |
Changes to tests/split.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994-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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994-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::*
}
test split-1.1 {basic split commands} {
split "a\n b\t\r c\n "
} {a {} b {} {} c {} {}}
test split-1.2 {basic split commands} {
|
| ︙ | ︙ |
Changes to tests/stack.test.
1 2 3 4 5 6 7 8 9 10 11 | # Tests that the stack size is big enough for the application. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | > | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Tests that the stack size is big enough for the application.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1998-2000 Ajuba Solutions.
#
# 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::*
}
# Note that a failure in this test may result in a crash of the executable.
test stack-1.1 {maxNestingDepth reached on infinite recursion} -body {
# do this in a sub process in case it segfaults
exec [interpreter] << {
proc recurse {} { recurse }
|
| ︙ | ︙ |
Changes to tests/string.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 |
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
#
# 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]} {
| | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
#
# 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Helper commands to test various optimizations, code paths, and special cases.
|
| ︙ | ︙ | |||
1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 |
set s 0000000001
binary scan $s a* x
run {string range $s $s end}
} 000000001
test string-12.23.$noComp {string range, surrogates, bug [11ae2be95dac9417]} fullutf {
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-13.1.$noComp {string repeat} {
list [catch {run {string repeat}} msg] $msg
} {1 {wrong # args: should be "string repeat string count"}}
test string-13.2.$noComp {string repeat} {
list [catch {run {string repeat abc 10 oops}} msg] $msg
} {1 {wrong # args: should be "string repeat string count"}}
| > > > > > > > > > > > > > > | 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 |
set s 0000000001
binary scan $s a* x
run {string range $s $s end}
} 000000001
test string-12.23.$noComp {string range, surrogates, bug [11ae2be95dac9417]} fullutf {
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
} {1 {wrong # args: should be "string repeat string count"}}
test string-13.2.$noComp {string repeat} {
list [catch {run {string repeat abc 10 oops}} msg] $msg
} {1 {wrong # args: should be "string repeat string count"}}
|
| ︙ | ︙ |
Changes to tests/stringObj.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 |
# Copyright (c) 1995-1997 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]} {
| | | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
# Copyright (c) 1995-1997 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testobj [llength [info commands testobj]]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testdstring [llength [info commands testdstring]]
testConstraint fullutf [expr {[string length \U010000] == 1}]
test stringObj-1.1 {string type registration} testobj {
set t [testobj types]
set first [string first "string" $t]
set result [expr {$first >= 0}]
} 1
test stringObj-2.1 {Tcl_NewStringObj} testobj {
set result ""
lappend result [testobj freeallvars]
lappend result [teststringobj set 1 abcd]
lappend result [testobj type 1]
lappend result [testobj refcount 1]
|
| ︙ | ︙ |
Changes to tests/subst.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Ajuba Solutions.
#
# 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Ajuba Solutions.
#
# 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testbytestring [llength [info commands testbytestring]]
|
| ︙ | ︙ | |||
278 279 280 281 282 283 284 |
set script [makeFile {
proc demo {string} {
subst $string
}
demo name2
} subst13.tcl]
} -body {
| | | | | | | | | 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 |
set script [makeFile {
proc demo {string} {
subst $string
}
demo name2
} subst13.tcl]
} -body {
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()}]
}
}
child eval [list source $script]
interp delete child
} -cleanup {
removeFile subst13.tcl
}
test subst-13.2 {Test for segfault} -body {
subst {[}
} -returnCodes error -result * -match glob
|
| ︙ | ︙ |
Changes to tests/switch.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 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::*
}
test switch-1.1 {simple patterns} {
switch a a {subst 1} b {subst 2} c {subst 3} default {subst 4}
} 1
test switch-1.2 {simple patterns} {
|
| ︙ | ︙ |
Changes to tests/tailcall.test.
1 2 3 4 5 6 7 8 9 10 11 12 |
# Commands covered: tailcall
#
# This file contains a collection of tests for experimental commands that are
# found in ::tcl::unsupported. The tests will migrate to normal test files
# if/when the commands find their way into the core.
#
# Copyright (c) 2008 by Miguel Sofer.
#
# 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: tailcall
#
# This file contains a collection of tests for experimental commands that are
# found in ::tcl::unsupported. The tests will migrate to normal test files
# if/when the commands find their way into the core.
#
# Copyright (c) 2008 by Miguel Sofer.
#
# 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testnrelevels [llength [info commands testnrelevels]]
|
| ︙ | ︙ |
Changes to tests/tcltest.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # Note that there are several places where the value of # tcltest::currentFailure is stored/reset in the -setup/-cleanup # of a test that has a body that runs [test] that will fail. # This is a workaround of using the same tcltest code that we are # 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 | | > | | < | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 |
# Note that there are several places where the value of
# tcltest::currentFailure is stored/reset in the -setup/-cleanup
# of a test that has a body that runs [test] that will fail.
# This is a workaround of using the same tcltest code that we are
# 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 child interp so the [test] being tested would not
# interfere with the [test] doing the testing.
#
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
namespace eval ::tcltest::test {
namespace import ::tcltest::*
makeFile {
package require tcltest 2.5
namespace import ::tcltest::test
test a-1.0 {test a} {
list 0
} {0}
test b-1.0 {test b} {
list 1
} {0}
|
| ︙ | ︙ | |||
59 60 61 62 63 64 65 |
} {1 1}
test tcltest-1.3 {tcltest -h} {exec} {
set result [catch {exec [interpreter] test.tcl -h} msg]
list $result [regexp Usage $msg]
} {1 0}
# -verbose, implicit & explicit testing of [verbose]
| | | | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
} {1 1}
test tcltest-1.3 {tcltest -h} {exec} {
set result [catch {exec [interpreter] test.tcl -h} msg]
list $result [regexp Usage $msg]
} {1 0}
# -verbose, implicit & explicit testing of [verbose]
proc child {msgVar args} {
upvar 1 $msgVar msg
interp create [namespace current]::i
# 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]]"
i eval "set tcltest::errorChannel\
\[[list open [set ef [makeFile {} error]] w]]"
i eval [list set argv0 [lindex $args 0]]
i eval [list set argv [lrange $args 1 end]]
|
| ︙ | ︙ | |||
95 96 97 98 99 100 101 |
if {[string length $err]} {
set code 1
append msg \n$err
}
return $code
}
test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrWin} {
| | | | | | | | | | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 |
if {[string length $err]} {
set code 1
append msg \n$err
}
return $code
}
test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrWin} {
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 [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 [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 [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 [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 [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 [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]
} {0 1 1 1 1}
test tcltest-2.6 {tcltest -verbose 't'} {
-constraints {unixOrWin}
-body {
set result [child msg test.tcl -verbose 't']
list $result $msg
}
-result {^0 .*a-1.0 start.*b-1.0 start}
-match regexp
}
test tcltest-2.6a {tcltest -verbose 'start'} {
-constraints {unixOrWin}
-body {
set result [child msg test.tcl -verbose start]
list $result $msg
}
-result {^0 .*a-1.0 start.*b-1.0 start}
-match regexp
}
test tcltest-2.7 {tcltest::verbose} {
|
| ︙ | ︙ | |||
174 175 176 177 178 179 180 |
}
-result {body {}}
}
test tcltest-2.8 {tcltest -verbose 'error'} {
-constraints {unixOrWin}
-body {
| | | | | | | | | | | | | | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 |
}
-result {body {}}
}
test tcltest-2.8 {tcltest -verbose 'error'} {
-constraints {unixOrWin}
-body {
set result [child msg test.tcl -verbose error]
list $result $msg
}
-result {errorInfo: foo.*errorCode: 9}
-match regexp
}
# -match, [match]
test tcltest-3.1 {tcltest -match 'a*'} {unixOrWin} {
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 [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 [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 [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}
test tcltest-3.5 {tcltest::match} {
-body {
set oldMatch [match]
match foo
set currentMatch [match]
match bar
set newMatch [match]
match $oldMatch
list $currentMatch $newMatch
}
-result {foo bar}
}
# -skip, [skip]
test tcltest-4.1 {tcltest -skip 'a*'} {unixOrWin} {
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 [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 [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 [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 [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}
test tcltest-4.6 {tcltest::skip} {
-body {
set oldSkip [skip]
skip foo
set currentSkip [skip]
skip bar
set newSkip [skip]
skip $oldSkip
list $currentSkip $newSkip
}
-result {foo bar}
}
# -constraints, -limitconstraints, [testConstraint],
# $constraintsSpecified, [limitConstraints]
test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrWin} {
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 [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}
test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} {
-body {
set r1 [testConstraint tcltestFakeConstraint]
|
| ︙ | ︙ | |||
336 337 338 339 340 341 342 |
# testConstraint knownBug $keepkb
# }
# -result {false knownBug knownBug}
#}
# -outfile, -errfile, [outputChannel], [outputFile], [errorChannel], [errorFile]
set printerror [makeFile {
| | | | | | | 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 |
# testConstraint knownBug $keepkb
# }
# -result {false knownBug knownBug}
#}
# -outfile, -errfile, [outputChannel], [outputFile], [errorChannel], [errorFile]
set printerror [makeFile {
package require tcltest 2.5
namespace import ::tcltest::*
puts [outputChannel] "a test"
::tcltest::PrintError "a really short string"
::tcltest::PrintError "a really really really really really really long \
string containing \"quotes\" and other bad bad stuff"
::tcltest::PrintError "a really really long string containing a \
\"Path/that/is/really/long/and/contains/no/spaces\""
::tcltest::PrintError "a really really long string containing a \
\"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\""
::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\""
exit
} printerror.tcl]
test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
-constraints unixOrWin
-body {
child msg $printerror
return $msg
}
-result {a test.*a really}
-match regexp
}
test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrWin unixExecs} {
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} {
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} {
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] \
$result1 $result2 \
[file exists a.tmp] [file delete a.tmp] \
[file exists b.tmp] [file delete b.tmp]
} {0 0 0 0 1 {} 1 {}}
|
| ︙ | ︙ | |||
459 460 461 462 463 464 465 |
removeFile efile
}
}
# -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
| | | 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 |
removeFile efile
}
}
# -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
# 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
} {0}
test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrWin} {
catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg
list [regexp userSpecifiedSkip $msg] \
|
| ︙ | ︙ | |||
506 507 508 509 510 511 512 |
}
}
removeFile test.tcl
# directory tests
set a [makeFile {
| | | | | 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 |
}
}
removeFile test.tcl
# directory tests
set a [makeFile {
package require tcltest 2.5
tcltest::makeFile {} a.tmp
puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]"
exit
} a.tcl]
set tdiaf [makeFile {} thisdirectoryisafile]
set normaldirectory [makeDirectory normaldirectory]
normalizePath normaldirectory
# -tmpdir, [temporaryDirectory]
test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrWin -setup {
file delete -force thisdirectorydoesnotexist
} -body {
child msg $a -tmpdir thisdirectorydoesnotexist
file exists [file join thisdirectorydoesnotexist a.tmp]
} -cleanup {
file delete -force thisdirectorydoesnotexist
} -result 1
test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
-constraints unixOrWin
-body {
child msg $a -tmpdir $tdiaf
return $msg
}
-result {*not a directory*}
-match glob
}
# Test non-writeable directories, non-readable directories with directory flags
set notReadableDir [file join [temporaryDirectory] notreadable]
|
| ︙ | ︙ | |||
555 556 557 558 559 560 561 |
catch {file attributes $notWriteableDir -readonly 1}
catch {testchmod 0 $notWriteableDir}
}
}
test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
-constraints {unix notRoot}
-body {
| | | | | 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 |
catch {file attributes $notWriteableDir -readonly 1}
catch {testchmod 0 $notWriteableDir}
}
}
test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
-constraints {unix notRoot}
-body {
child msg $a -tmpdir $notReadableDir
return $msg
}
-result {*not readable*}
-match glob
}
# This constraint doesn't go at the top of the file so that it doesn't
# interfere with tcltest-5.5
testConstraint notFAT [expr {
![regexp {^(FAT\d*|NTFS)$} [lindex [file system $notWriteableDir] 1]]
|| $::tcl_platform(platform) eq "unix" || [llength [info commands testchmod]]
}]
# FAT/NTFS permissions are fairly hopeless; ignore this test if that FS is used
test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {
-constraints {unixOrWin notRoot notFAT}
-body {
child msg $a -tmpdir $notWriteableDir
return $msg
}
-result {*not writeable*}
-match glob
}
test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {
-constraints unixOrWin
-body {
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]
}
-cleanup {
catch {file delete [file join $normaldirectory a.tmp]}
}
|
| ︙ | ︙ | |||
626 627 628 629 630 631 632 |
# -testdir, [testsDirectory]
test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
-constraints unixOrWin
-setup {
file delete -force thisdirectorydoesnotexist
}
-body {
| | | | | | 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 |
# -testdir, [testsDirectory]
test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
-constraints unixOrWin
-setup {
file delete -force thisdirectorydoesnotexist
}
-body {
child msg $a -testdir thisdirectorydoesnotexist
return $msg
}
-match glob
-result {*does not exist*}
}
test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {
-constraints unixOrWin
-body {
child msg $a -testdir $tdiaf
return $msg
}
-match glob
-result {*not a directory*}
}
test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {
-constraints {unix notRoot}
-body {
child msg $a -testdir $notReadableDir
return $msg
}
-match glob
-result {*not readable*}
}
test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {
-constraints unixOrWin
-body {
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]] \
[file exists [file join [temporaryDirectory] a.tmp]]
}
-cleanup {
file delete [file join [temporaryDirectory] a.tmp]
|
| ︙ | ︙ | |||
732 733 734 735 736 737 738 |
removeDirectory normaldirectory
# -file, -notfile, [matchFiles], [skipFiles]
test tcltest-9.1 {-file d*.tcl} -constraints {unixOrWin} -setup {
set old [testsDirectory]
testsDirectory [file dirname [info script]]
} -body {
| | | | 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 |
removeDirectory normaldirectory
# -file, -notfile, [matchFiles], [skipFiles]
test tcltest-9.1 {-file d*.tcl} -constraints {unixOrWin} -setup {
set old [testsDirectory]
testsDirectory [file dirname [info script]]
} -body {
child msg [file join [testsDirectory] all.tcl] -file d*.test
return $msg
} -cleanup {
testsDirectory $old
} -match regexp -result {dstring\.test}
test tcltest-9.2 {-file d*.tcl} -constraints {unixOrWin} -setup {
set old [testsDirectory]
testsDirectory [file dirname [info script]]
} -body {
child msg [file join [testsDirectory] all.tcl] \
-file d*.test -notfile dstring*
regexp {dstring\.test} $msg
} -cleanup {
testsDirectory $old
} -result 0
test tcltest-9.3 {matchFiles} {
|
| ︙ | ︙ | |||
781 782 783 784 785 786 787 |
test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup {
set d [makeDirectory tmp]
makeDirectory foo $d
makeFile {} fee $d
file copy [file join [file dirname [info script]] all.tcl] $d
} -body {
| | | | | | | | 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 |
test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup {
set d [makeDirectory tmp]
makeDirectory foo $d
makeFile {} fee $d
file copy [file join [file dirname [info script]] all.tcl] $d
} -body {
child msg [file join [temporaryDirectory] all.tcl] -file f*
regexp {exiting with errors:} $msg
} -cleanup {
file delete [file join $d all.tcl]
removeFile fee $d
removeDirectory foo $d
removeDirectory tmp
} -result 0
# -preservecore, [preserveCore]
set mc [makeFile {
package require tcltest 2.5
namespace import ::tcltest::test
test makecore {make a core file} {
set f [open core w]
close $f
} {}
::tcltest::cleanupTests
return
} makecore.tcl]
cd [temporaryDirectory]
test tcltest-10.1 {-preservecore 0} {unixOrWin} {
child msg $mc -preservecore 0
file delete core
regexp "Core file produced" $msg
} {0}
test tcltest-10.2 {-preservecore 1} {unixOrWin} {
child msg $mc -preservecore 1
file delete core
regexp "Core file produced" $msg
} {1}
test tcltest-10.3 {-preservecore 2} {unixOrWin} {
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} {
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]
} {1 1 1 {}}
# Removing this test. It makes no sense to test the ability of
# [preserveCore] to accept an invalid value that will cause errors
|
| ︙ | ︙ | |||
843 844 845 846 847 848 849 |
# }
# -result {foo foo}
#}
removeFile makecore.tcl
# -load, -loadfile, [loadScript], [loadFile]
set contents {
| | | | 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 |
# }
# -result {foo foo}
#}
removeFile makecore.tcl
# -load, -loadfile, [loadScript], [loadFile]
set contents {
package require tcltest 2.5
namespace import tcltest::*
puts [outputChannel] $::tcltest::loadScript
exit
}
set loadfile [makeFile $contents load.tcl]
test tcltest-12.1 {-load xxx} {unixOrWin} {
child msg $loadfile -load xxx
return $msg
} {xxx}
# Using child process because of -debug usage.
test tcltest-12.2 {-loadfile load.tcl} {unixOrWin} {
catch {exec [interpreter] $loadfile -debug 2 -loadfile $loadfile} msg
list \
|
| ︙ | ︙ | |||
939 940 941 942 943 944 945 |
} single1.test $spd
makeFile {
unset foo
} single2.test $spd
set allfile [makeFile {
| | | | | 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 |
} single1.test $spd
makeFile {
unset foo
} single2.test $spd
set allfile [makeFile {
package require tcltest 2.5
namespace import tcltest::*
testsDirectory [file join [temporaryDirectory] singleprocdir]
runAllTests
} all-single.tcl $spd]
cd [workingDirectory]
test tcltest-14.1 {-singleproc - single process} {
-constraints {unixOrWin}
-body {
child msg $allfile -singleproc 0 -tmpdir [temporaryDirectory]
return $msg
}
-result {Test file error: can't unset .foo.: no such variable}
-match regexp
}
test tcltest-14.2 {-singleproc - multiple process} {
-constraints {unixOrWin}
-body {
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}
-match regexp
}
test tcltest-14.3 {singleProcess} {
|
| ︙ | ︙ | |||
996 997 998 999 1000 1001 1002 |
# all.tcl files.
set dtd [makeDirectory dirtestdir]
set dtd1 [makeDirectory dirtestdir2.1 $dtd]
set dtd2 [makeDirectory dirtestdir2.2 $dtd]
set dtd3 [makeDirectory dirtestdir2.3 $dtd]
makeFile {
| | | | | | | | | | | 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 |
# all.tcl files.
set dtd [makeDirectory dirtestdir]
set dtd1 [makeDirectory dirtestdir2.1 $dtd]
set dtd2 [makeDirectory dirtestdir2.2 $dtd]
set dtd3 [makeDirectory dirtestdir2.3 $dtd]
makeFile {
package require tcltest 2.5
namespace import -force tcltest::*
testsDirectory [file join [temporaryDirectory] dirtestdir]
runAllTests
} all.tcl $dtd
makeFile {
package require tcltest 2.5
namespace import -force tcltest::*
testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.1]
runAllTests
} all.tcl $dtd1
makeFile {
package require tcltest 2.5
namespace import -force tcltest::*
testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.2]
runAllTests
} all.tcl $dtd2
makeFile {
package require tcltest 2.5
namespace import -force tcltest::*
testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3]
runAllTests
} all.tcl $dtd3
test tcltest-15.1 {basic directory walking} {
-constraints {unixOrWin}
-body {
if {[child msg \
[file join $dtd all.tcl] \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-match regexp
-returnCodes 1
-result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123]}
}
test tcltest-15.2 {-asidefromdir} {
-constraints {unixOrWin}
-body {
if {[child msg \
[file join $dtd all.tcl] \
-asidefromdir dirtestdir2.3 \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-match regexp
-returnCodes 1
-result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[12].*Tests located in:.*dirtestdir2.[12].*dirtestdir2.[12] test ended at .*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Error: No test files remain after applying your match and skip patterns!
Error: No test files remain after applying your match and skip patterns!
Error: No test files remain after applying your match and skip patterns!$}
}
test tcltest-15.3 {-relateddir, non-existent dir} {
-constraints {unixOrWin}
-body {
if {[child msg \
[file join $dtd all.tcl] \
-relateddir [file join [temporaryDirectory] dirtestdir0] \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-returnCodes 1
-match regexp
-result {[^~]|dirtestdir[^2]}
}
test tcltest-15.4 {-relateddir, subdir} {
-constraints {unixOrWin}
-body {
if {[child msg \
[file join $dtd all.tcl] \
-relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-returnCodes 1
-match regexp
-result {Tests located in:.*dirtestdir2.[^23]}
}
test tcltest-15.5 {-relateddir, -asidefromdir} {
-constraints {unixOrWin}
-body {
if {[child msg \
[file join $dtd all.tcl] \
-relateddir "dirtestdir2.1 dirtestdir2.2" \
-asidefromdir dirtestdir2.2 \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
|
| ︙ | ︙ | |||
1144 1145 1146 1147 1148 1149 1150 |
set oldoptions $::env(TCLTEST_OPTIONS)
} else {
set oldoptions none
}
# 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) { }
| | | | | | | | | | | | | | 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 |
set oldoptions $::env(TCLTEST_OPTIONS)
} else {
set oldoptions none
}
# 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 child1
child1 eval [list set argv {-debug 2}]
child1 alias puts puts
interp create child2
child2 alias puts puts
} -cleanup {
interp delete child2
interp delete child1
if {$oldoptions eq "none"} {
unset ::env(TCLTEST_OPTIONS)
} else {
set ::env(TCLTEST_OPTIONS) $oldoptions
}
} -body {
child1 eval [package ifneeded tcltest [package provide tcltest]]
child1 eval tcltest::debug
set ::env(TCLTEST_OPTIONS) "-debug 3"
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}
# Begin testing of tcltest procs ...
cd [temporaryDirectory]
# PrintError
test tcltest-20.1 {PrintError} {unixOrWin} {
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]
} {1 1 1 1 1 1}
cd [workingDirectory]
removeFile printerror.tcl
|
| ︙ | ︙ | |||
1382 1383 1384 1385 1386 1387 1388 |
} -result {^$} -output {foo is 2} -match regexp
# test all.tcl usage (runAllTests); simulate .test file failure, as well as
# crashes to determine whether or not these errors are logged.
set atd [makeDirectory alltestdir]
makeFile {
| | | | | 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 |
} -result {^$} -output {foo is 2} -match regexp
# test all.tcl usage (runAllTests); simulate .test file failure, as well as
# crashes to determine whether or not these errors are logged.
set atd [makeDirectory alltestdir]
makeFile {
package require tcltest 2.5
namespace import -force tcltest::*
testsDirectory [file join [temporaryDirectory] alltestdir]
runAllTests
} all.tcl $atd
makeFile {
exit 1
} exit.test $atd
makeFile {
error "throw an error"
} error.test $atd
makeFile {
package require tcltest 2.5
namespace import -force tcltest::*
test foo-1.1 {foo} {
-body { return 1 }
-result {1}
}
cleanupTests
} test.test $atd
# Must use a child process because stdout/stderr parsing can't be
# duplicated in child interp.
test tcltest-22.1 {runAllTests} {
-constraints {unixOrWin}
-body {
exec [interpreter] \
[file join $atd all.tcl] \
-verbose t -tmpdir [temporaryDirectory]
}
|
| ︙ | ︙ | |||
1793 1794 1795 1796 1797 1798 1799 |
} -cleanup {
set ::tcltest::currentFailure $fail
verbose $v
} -match glob -output {*generated error; Return code was: 1*}
test tcltest-26.1 {Bug/RFE 1017151} -setup {
makeFile {
| | | | | | 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 |
} -cleanup {
set ::tcltest::currentFailure $fail
verbose $v
} -match glob -output {*generated error; Return code was: 1*}
test tcltest-26.1 {Bug/RFE 1017151} -setup {
makeFile {
package require tcltest 2.5
set ::errorInfo "Should never see this"
tcltest::test tcltest-26.1.0 {
no errorInfo when only return code mismatch
} -body {
set x 1
} -returnCodes error -result 1
tcltest::cleanupTests
} test.tcl
} -body {
child msg [file join [temporaryDirectory] test.tcl]
return $msg
} -cleanup {
removeFile test.tcl
} -match glob -result {*
---- Return code should have been one of: 1
==== tcltest-26.1.0 FAILED*}
test tcltest-26.2 {Bug/RFE 1017151} -setup {
makeFile {
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"
} -cleanup {
error "cleanup error"
} -result 1
tcltest::cleanupTests
} test.tcl
} -body {
child msg [file join [temporaryDirectory] test.tcl]
return $msg
} -cleanup {
removeFile test.tcl
} -match glob -result {*
---- errorInfo: body error
*
---- errorInfo(cleanup): cleanup error*}
|
| ︙ | ︙ |
Changes to tests/tcltests.tcl.
1 2 | #! /usr/bin/env tclsh | | | 1 2 3 4 5 6 7 8 9 10 |
#! /usr/bin/env tclsh
package require tcltest 2.5
namespace import ::tcltest::*
testConstraint exec [llength [info commands exec]]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint fileevent [llength [info commands fileevent]]
testConstraint thread [
expr {0 == [catch {package require Thread 2.7-}]}]
testConstraint notValgrind [expr {![testConstraint valgrind]}]
|
| ︙ | ︙ |
Changes to tests/thread.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
#
# 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
#
# 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::*
}
# when thread::release is used, -wait is passed in order allow the thread to
# be fully finalized, which avoids valgrind "still reachable" reports.
::tcltest::loadTestedCommands
|
| ︙ | ︙ | |||
35 36 37 38 39 40 41 |
rename update ""
thread::release
}
proc getThreadErrorFromInfo { info } {
set list [split $info \n]
set idx [lsearch -glob $list "*eval*unwound*"]
| | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
rename update ""
thread::release
}
proc getThreadErrorFromInfo { info } {
set list [split $info \n]
set idx [lsearch -glob $list "*eval*unwound*"]
if {$idx >= 0} then {
return [lindex $list $idx]
}
set idx [lsearch -glob $list "*eval*canceled*"]
if {$idx >= 0} then {
return [lindex $list $idx]
}
return ""; # some other error we do not care about.
}
proc findThreadError { info } {
foreach error [lreverse $info] {
|
| ︙ | ︙ | |||
801 802 803 804 805 806 807 |
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
| | | 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 |
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.22 {cancel: child interp} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
[string map [list %ID% [thread::id]] {
set i [interp create]
$i eval "package require -exact Thread [package present Thread]"
$i eval {
|
| ︙ | ︙ | |||
831 832 833 834 835 836 837 |
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval canceled}}
| | | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 |
[expr {[info exists ::threadId] ? \
$::threadId == $serverthread : 0}] \
[expr {[info exists ::threadError($serverthread)] ? \
[findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval canceled}}
test thread-7.23 {cancel: child interp -unwind} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
[string map [list %ID% [thread::id]] {
set i [interp create]
$i eval "package require -exact Thread [package present Thread]"
$i eval {
|
| ︙ | ︙ |
Changes to tests/timer.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 |
# Copyright (c) 1997 by 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]} {
| | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright (c) 1997 by 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::*
}
test timer-1.1 {Tcl_CreateTimerHandler procedure} -setup {
foreach i [after info] {
after cancel $i
}
|
| ︙ | ︙ | |||
564 565 566 567 568 569 570 |
set x before
after 300
update
return $x
} -result {before after2 after4}
test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup {
| | | | | | | | 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 |
set x before
after 300
update
return $x
} -result {before after2 after4}
test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup {
interp create child
child eval namespace export after
child eval namespace eval foo namespace import ::after
} -body {
child eval foo::after 1
child eval namespace origin foo::after
} -cleanup {
# Bug will cause crash here; would cause failure otherwise
interp delete child
} -result ::after
test timer-11.1 {Bug 1350291: [after] overflowing 32-bit field} -body {
set b ok
set a [after 0x100000001 {set b "after fired early"}]
after 100 set done 1
vwait done
|
| ︙ | ︙ |
Changes to tests/tm.test.
1 2 3 4 5 6 7 8 | # This file contains tests for the ::tcl::tm::* commands. # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 2004 by Donal K. Fellows. # All rights reserved. | < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
# This file contains tests for the ::tcl::tm::* commands.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 2004 by Donal K. Fellows.
# All rights reserved.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test tm-1.1 {tm: path command exists} {
catch { ::tcl::tm::path }
info commands ::tcl::tm::path
} ::tcl::tm::path
|
| ︙ | ︙ |
Changes to tests/trace.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: trace # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 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. | > | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Commands covered: trace
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
|
| ︙ | ︙ | |||
2193 2194 2195 2196 2197 2198 2199 |
foo {if {[catch {bar}]} {
return "error"
} else {
return "ok"
}} 2 error leavestep
foo foo 0 error leave}}
| | | | | | 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 |
foo {if {[catch {bar}]} {
return "error"
} else {
return "ok"
}} 2 error leavestep
foo foo 0 error leave}}
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 child {
set info {}
set res {}
proc foo {} {
if {[catch {bar}]} {
return "error"
} else {
|
| ︙ | ︙ | |||
2225 2226 2227 2228 2229 2230 2231 |
lappend res [foo]
trace remove execution foo {enter enterstep leave leavestep} \
[list traceExecute foo]
list $res
}]
| | | 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 |
lappend res [foo]
trace remove execution foo {enter enterstep leave leavestep} \
[list traceExecute foo]
list $res
}]
interp delete child
lappend res [join $info \n]
} {{error error} {foo foo enter
foo {if {[catch {bar}]} {
return "error"
} else {
return "ok"
}} enterstep
|
| ︙ | ︙ |
Changes to tests/unixFCmd.test.
1 2 3 4 5 6 7 8 9 10 11 12 |
# This file tests the tclUnixFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# This file tests the tclUnixFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testchmod [llength [info commands testchmod]]
|
| ︙ | ︙ |
Changes to tests/unixFile.test.
1 2 3 4 5 6 7 8 9 10 11 12 |
# This file contains tests for the routines in the file tclUnixFile.c
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# This file contains tests for the routines in the file tclUnixFile.c
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testfindexecutable [llength [info commands testfindexecutable]]
|
| ︙ | ︙ |
Changes to tests/unixForkEvent.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for the procedures in the file # tclUnixNotify.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1997 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. | > | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# This file contains a collection of tests for the procedures in the file
# tclUnixNotify.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1997 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::*
}
testConstraint testfork [llength [info commands testfork]]
# Test if the notifier thread is well initialized in a forked interpreter
# by Tcl_InitNotifier
test unixforkevent-1.1 {fork and test writeable event} \
-constraints {testfork nonPortable} \
|
| ︙ | ︙ |
Changes to tests/unixInit.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # The file tests the functions in the tclUnixInit.c file. # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (c) 1997 by 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. | > | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# The file tests the functions in the tclUnixInit.c file.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1997 by 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::*
}
unset -nocomplain path
catch {set oldlang $env(LANG)}
set env(LANG) C
# Some tests require the testgetencpath command
testConstraint testgetencpath [llength [info commands testgetencpath]]
|
| ︙ | ︙ |
Changes to tests/unixNotfy.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# This file contains tests for tclUnixNotfy.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# This file contains tests for tclUnixNotfy.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by 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::*
}
# When run in a Tk shell, these tests hang.
testConstraint noTk [expr {0 != [catch {package present Tk}]}]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
|
| ︙ | ︙ |
Changes to tests/unknown.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: unknown # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 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. | > | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Commands covered: unknown
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 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::*
}
unset -nocomplain x
catch {rename unknown unknown.old}
test unknown-1.1 {non-existent "unknown" command} {
list [catch {_non-existent_ foo bar} msg] $msg
} {1 {invalid command name "_non-existent_"}}
|
| ︙ | ︙ |
Changes to tests/unload.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2003-2004 by Georgios Petasis
#
# 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2003-2004 by Georgios Petasis
#
# 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Figure out what extension is used for shared libraries on this
|
| ︙ | ︙ | |||
152 153 154 155 156 157 158 |
} {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
test unload-3.3 {unloading of a package that has never been loaded from a safe interpreter} -setup {
loadIfNotPresent pkga
} -constraints [list $dll $loaded] -returnCodes error -match glob -body {
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 {
| | | | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 |
} {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
test unload-3.3 {unloading of a package that has never been loaded from a safe interpreter} -setup {
loadIfNotPresent pkga
} -constraints [list $dll $loaded] -returnCodes error -match glob -body {
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] < 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] < 0} {
load [file join $testDir pkgua$ext] pkgua child
}
} -constraints [list $dll $loaded] -body {
list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
[unload [file join $testDir pkgua$ext] {} child] \
[child eval info commands pkgua_*] \
[child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
|
| ︙ | ︙ |
Changes to tests/uplevel.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 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::*
}
proc a {x y} {
newset z [expr $x+$y]
return $z
}
|
| ︙ | ︙ |
Changes to tests/upvar.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 |
# Copyright (c) 1994 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]} {
| | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testupvar [llength [info commands testupvar]]
|
| ︙ | ︙ |
Changes to tests/utf.test.
1 2 3 4 5 6 7 8 9 10 11 |
# This file contains a collection of tests for tclUtf.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# This file contains a collection of tests for tclUtf.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint ucs2 [expr {[format %c 0x010000] eq "\uFFFD"}]
|
| ︙ | ︙ |
Changes to tests/util.test.
1 2 3 4 5 6 7 8 9 10 |
# This file is a Tcl script to test the code in the file tclUtil.c.
# This file is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995-1998 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
# This file is a Tcl script to test the code in the file tclUtil.c.
# This file is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995-1998 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint controversialNaN 1
|
| ︙ | ︙ | |||
735 736 737 738 739 740 741 742 743 744 745 746 747 748 |
} -result {}
test util-9.57 {Tcl_GetIntForIndex} {
string index abcd end+-0x10000000000000000
} {}
test util-9.58 {Tcl_GetIntForIndex} -body {
string index abcd end--0x8000000000000000
} -result {}
test util-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
convertDouble 0x0000000000000000
} {0.0}
test util-10.2 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
convertDouble 0x8000000000000000
} {-0.0}
| > > > | 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 |
} -result {}
test util-9.57 {Tcl_GetIntForIndex} {
string index abcd end+-0x10000000000000000
} {}
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
} {0.0}
test util-10.2 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
convertDouble 0x8000000000000000
} {-0.0}
|
| ︙ | ︙ |
Changes to tests/var.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 |
# Copyright (c) 1997 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]} {
| | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# Copyright (c) 1997 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testupvar [llength [info commands testupvar]]
|
| ︙ | ︙ | |||
1037 1038 1039 1040 1041 1042 1043 |
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
array unset A
rename doit {}
} -result 0
test var-22.1 {leak in localVarName intrep: Bug 80304238ac} -setup {
proc doit {} {
| | | | | 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 |
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
array unset A
rename doit {}
} -result 0
test var-22.1 {leak in localVarName intrep: Bug 80304238ac} -setup {
proc doit {} {
interp create child
child eval {
proc doit script {
eval $script
set foo bar
}
doit {foreach foo baz {}}
}
interp delete child
}
} -constraints memory -body {
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
doit
set tmp $end
set end [getbytes]
|
| ︙ | ︙ |
Changes to tests/while-old.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 |
# Copyright (c) 1994-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]} {
| | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright (c) 1994-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::*
}
test while-old-1.1 {basic while loops} {
set count 0
while {$count < 10} {set count [expr $count+1]}
set count
|
| ︙ | ︙ |
Changes to tests/while.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# Commands covered: while
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: while
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 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::*
}
# Basic "while" operation.
catch {unset i}
catch {unset a}
|
| ︙ | ︙ |
Changes to tests/winConsole.test.
1 2 3 4 5 6 7 8 9 10 11 12 |
# This file tests the tclWinConsole.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# This file tests the tclWinConsole.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 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::*
}
test winConsole-1.1 {Console file channel: non-blocking gets} {win interactive} {
set oldmode [fconfigure stdin]
|
| ︙ | ︙ |
Changes to tests/winDde.test.
1 2 3 4 5 6 7 8 9 10 11 12 |
# This file tests the tclWinDde.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 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]} {
| | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# This file tests the tclWinDde.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 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::*
}
testConstraint debug [::tcl::pkgconfig get debug]
testConstraint dde 0
if {[testConstraint win]} {
if {![catch {
|
| ︙ | ︙ | |||
39 40 41 42 43 44 45 |
set f [open $::scriptName w+]
puts $f [list set ddeServerName $ddeServerName]
puts $f [list load $::ddelib dde]
puts $f {
# DDE child server -
#
if {"::tcltest" ni [namespace children]} {
| | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
set f [open $::scriptName w+]
puts $f [list set ddeServerName $ddeServerName]
puts $f [list load $::ddelib dde]
puts $f {
# DDE child server -
#
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# If an error occurs during the tests, this process may end up not
# being closed down. To deal with this we create a 30s timeout.
proc ::DoTimeout {} {
global done ddeServerName
|
| ︙ | ︙ | |||
275 276 277 278 279 280 281 |
} -cleanup {
dde execute TclEval $name {set done 1}
update
} -result "ch\xEDld-6.6"
# -------------------------------------------------------------------------
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 |
} -cleanup {
dde execute TclEval $name {set done 1}
update
} -result "ch\xEDld-6.6"
# -------------------------------------------------------------------------
test winDde-7.1 {Load DDE in child interpreter} -constraints dde -setup {
interp create child
} -body {
child eval [list load $::ddelib Dde]
child eval [list dde servername -- dde-interp-7.1]
} -cleanup {
interp delete child
} -result {dde-interp-7.1}
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 {}]
set m [list [list TclEval dde-interp-7.5]]
if {$m in $s} {
set s
}
} -result {}
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 child
} -result {{TclEval dde-interp-7.3}}
test winDde-7.4 {interp name collision with -force} -constraints dde -setup {
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 child
} -result {dde-interp-7.4}
test winDde-7.5 {interp name collision without -force} -constraints dde -setup {
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 child
} -result "dde-interp-7.5 #2"
# -------------------------------------------------------------------------
test winDde-8.1 {Safe DDE load} -constraints dde -setup {
interp create -safe child
child invokehidden load $::ddelib Dde
} -body {
child eval dde servername child
} -cleanup {
interp delete child
} -returnCodes error -result {invalid command name "dde"}
test winDde-8.2 {Safe DDE set servername} -constraints dde -setup {
interp create -safe child
child invokehidden load $::ddelib Dde
} -body {
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 child
child invokehidden load $::ddelib Dde
child invokehidden dde servername child
} -body {
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 child
child invokehidden load $::ddelib Dde
child invokehidden dde servername child
} -body {
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 child
child invokehidden load $::ddelib Dde
child invokehidden dde servername child
} -body {
child eval set a 1
dde request TclEval child a
} -cleanup {
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 child
child invokehidden load $::ddelib Dde
child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
} -body {
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 child
child invokehidden load $::ddelib Dde
child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
child invokehidden dde servername -handler DDEACCEPT child
} -body {
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 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 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 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 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 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 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 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 child [list [list set x 1]]
child eval set x
} -cleanup {interp delete child} -returnCodes error -result {invalid command name "set x 1"}
# -------------------------------------------------------------------------
test winDde-9.1 {External safe DDE check string passing} -constraints {dde stdio} -setup {
set name ch\xEDld-9.1
set child [createChildProcess $name -handler Handler1]
file copy -force script1.tcl dde-script.tcl
|
| ︙ | ︙ | |||
477 478 479 480 481 482 483 |
update
file delete -force -- dde-script.tcl
} -result {null data}
# -------------------------------------------------------------------------
#cleanup
| | | 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 |
update
file delete -force -- dde-script.tcl
} -result {null data}
# -------------------------------------------------------------------------
#cleanup
#catch {interp delete $child}; # ensure we clean up the child.
file delete -force $::scriptName
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/winFCmd.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# This file tests the tclWinFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996-1997 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# This file tests the tclWinFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996-1997 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Initialise the test constraints
|
| ︙ | ︙ | |||
380 381 382 383 384 385 386 |
if {$ndx > 50000} {
return -code error "limit reached without finding a collistion."
}
set filename [file join $dirname Test[incr ndx]]
set f [open $filename w]
close $f
file stat $filename stat
| | | 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 |
if {$ndx > 50000} {
return -code error "limit reached without finding a collistion."
}
set filename [file join $dirname Test[incr ndx]]
set f [open $filename w]
close $f
file stat $filename stat
if {[set n [lsearch -exact -integer $inodes $stat(ino)]] >= 0} {
return [list [file join $dirname Test$n] $filename]
}
lappend inodes $stat(ino)
unset stat
}
}
|
| ︙ | ︙ |
Changes to tests/winFile.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file tests the tclWinFile.c file. # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (c) 1997 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. | > | < | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# This file tests the tclWinFile.c file.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1997 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint notNTFS 0
|
| ︙ | ︙ |
Changes to tests/winNotify.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# This file tests the tclWinNotify.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# This file tests the tclWinNotify.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testeventloop [expr {[info commands testeventloop] != {}}]
|
| ︙ | ︙ |
Changes to tests/winPipe.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # # Copyright (c) 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. | > | | > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
#
# Copyright (c) 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::*
}
unset -nocomplain path
catch {
::tcltest::loadTestedCommands
package require -exact Tcltest [info patchlevel]
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
}
|
| ︙ | ︙ |
Changes to tests/winTime.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# This file tests the tclWinTime.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# This file tests the tclWinTime.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 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::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testwinclock [llength [info commands testwinclock]]
|
| ︙ | ︙ |
Changes to tests/zipfs.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# The file tests the tclZlib.c file.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1996-1998 by 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# The file tests the tclZlib.c file.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1996-1998 by 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::*
}
testConstraint zipfs [expr {
[llength [info commands zlib]] && [regexp tcltest [info nameofexecutable]]
}]
testConstraint zipfslib 1
|
| ︙ | ︙ |
Changes to tests/zlib.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# The file tests the tclZlib.c file.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1996-1998 by 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]} {
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# The file tests the tclZlib.c file.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1996-1998 by 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::*
}
testConstraint zlib [llength [info commands zlib]]
testConstraint recentZlib 0
catch {
# Work around a bug in some versions of zlib; known to manifest on at
|
| ︙ | ︙ |
Changes to tools/checkLibraryDoc.tcl.
| ︙ | ︙ | |||
63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
Tk_ErrorHandler \
Tk_FakeWin \
Tk_Font \
Tk_FontMetrics \
Tk_GeomMgr \
Tk_Image \
Tk_ImageMaster \
Tk_ImageType \
Tk_Item \
Tk_ItemType \
Tk_OptionSpec\
Tk_OptionTable \
Tk_OptionType \
Tk_PhotoHandle \
| > | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
Tk_ErrorHandler \
Tk_FakeWin \
Tk_Font \
Tk_FontMetrics \
Tk_GeomMgr \
Tk_Image \
Tk_ImageMaster \
Tk_ImageModel \
Tk_ImageType \
Tk_Item \
Tk_ItemType \
Tk_OptionSpec\
Tk_OptionTable \
Tk_OptionType \
Tk_PhotoHandle \
|
| ︙ | ︙ |
Changes to tools/mkdepend.tcl.
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
# Results:
# Raw dependency list pairs.
proc readDepends {chan} {
set line ""
array set depends {}
| | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
# Results:
# Raw dependency list pairs.
proc readDepends {chan} {
set line ""
array set depends {}
while {[gets $chan line] >= 0} {
if {[regexp {^#line [0-9]+ \"(.*)\"$} $line dummy fname] != 0} {
set fname [file normalize $fname]
if {![info exists target]} {
# this is ourself
set target $fname
puts stderr "processing [file tail $fname]"
} else {
|
| ︙ | ︙ |
Changes to tools/tcltk-man2html.tcl.
| ︙ | ︙ | |||
625 626 627 628 629 630 631 632 633 634 635 636 637 638 |
Tk_3DBorder Tk_Get3DBorder
Tk_Anchor Tk_GetAnchor
Tk_Cursor Tk_GetCursor
Tk_Dash Tk_GetDash
Tk_Font Tk_GetFont
Tk_Image Tk_GetImage
Tk_ImageMaster Tk_GetImage
Tk_ItemType Tk_CreateItemType
Tk_Justify Tk_GetJustify
Ttk_Theme Ttk_GetTheme
}
array set exclude_refs_map {
bind.n {button destroy option}
clock.n {next}
| > | 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 |
Tk_3DBorder Tk_Get3DBorder
Tk_Anchor Tk_GetAnchor
Tk_Cursor Tk_GetCursor
Tk_Dash Tk_GetDash
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
}
array set exclude_refs_map {
bind.n {button destroy option}
clock.n {next}
|
| ︙ | ︙ |
Changes to tools/uniParse.tcl.
| ︙ | ︙ | |||
64 65 66 67 68 69 70 |
return [list $categoryIndex $toupper $tolower $totitle]
}
proc uni::getGroup {value} {
variable groups
set gIndex [lsearch -exact $groups $value]
| | | | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 |
return [list $categoryIndex $toupper $tolower $totitle]
}
proc uni::getGroup {value} {
variable groups
set gIndex [lsearch -exact $groups $value]
if {$gIndex < 0} {
set gIndex [llength $groups]
lappend groups $value
}
return $gIndex
}
proc uni::addPage {info} {
variable pMap
variable pages
variable shift
set pIndex [lsearch -exact $pages $info]
if {$pIndex < 0} {
set pIndex [llength $pages]
lappend pages $info
}
lappend pMap [expr {$pIndex << $shift}]
return
}
|
| ︙ | ︙ |
Changes to unix/Makefile.in.
| ︙ | ︙ | |||
871 872 873 874 875 876 877 878 879 880 881 882 883 884 |
# This keeps tcltest from picking up an already installed version of the Tcl
# library.
SHELL_ENV = @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@} \
TCLLIBPATH="@abs_builddir@/pkgs" \
TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"
${TCLTEST_EXE}: ${TCLTEST_OBJS} ${TCL_LIB_FILE} ${TCL_STUB_LIB_FILE} ${BUILD_DLTEST}
$(MAKE) tcltest-real LIB_RUNTIME_DIR="`pwd`"
tcltest-real:
${CC} ${CFLAGS} ${LDFLAGS} ${TCLTEST_OBJS} \
@TCL_BUILD_LIB_SPEC@ ${TCL_STUB_LIB_FILE} ${LIBS} @EXTRA_TCLSH_LIBS@ \
${CC_SEARCH_FLAGS} -o ${TCLTEST_EXE}
| > | 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 |
# This keeps tcltest from picking up an already installed version of the Tcl
# library.
SHELL_ENV = @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@} \
TCLLIBPATH="@abs_builddir@/pkgs" \
TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"
${TCLTEST_EXE}: ${TCLTEST_OBJS} ${TCL_LIB_FILE} ${TCL_STUB_LIB_FILE} ${BUILD_DLTEST}
rm -rf $(TOP_DIR)/tests/safe-stock86.test
$(MAKE) tcltest-real LIB_RUNTIME_DIR="`pwd`"
tcltest-real:
${CC} ${CFLAGS} ${LDFLAGS} ${TCLTEST_OBJS} \
@TCL_BUILD_LIB_SPEC@ ${TCL_STUB_LIB_FILE} ${LIBS} @EXTRA_TCLSH_LIBS@ \
${CC_SEARCH_FLAGS} -o ${TCLTEST_EXE}
|
| ︙ | ︙ | |||
1044 1045 1046 1047 1048 1049 1050 | @echo "Installing package cookiejar 0.2 files to $(SCRIPT_INSTALL_DIR)/cookiejar0.2/" @for i in $(TOP_DIR)/library/cookiejar/*.tcl; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done @for i in $(TOP_DIR)/library/cookiejar/*.gz; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done | | | | 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 | @echo "Installing package cookiejar 0.2 files to $(SCRIPT_INSTALL_DIR)/cookiejar0.2/" @for i in $(TOP_DIR)/library/cookiejar/*.tcl; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done @for i in $(TOP_DIR)/library/cookiejar/*.gz; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done @echo "Installing package http 2.9.5 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \ "$(MODULE_INSTALL_DIR)/9.0/http-2.9.5.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"; \ done @echo "Installing package msgcat 1.7.1 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \ "$(MODULE_INSTALL_DIR)/9.0/msgcat-1.7.1.tm" |
| ︙ | ︙ | |||
2225 2226 2227 2228 2229 2230 2231 | mkdir -p RPMS/$$platform && \ rpmbuild -bb THIS.TCL.SPEC && \ mv RPMS/$$platform/*.rpm .; \ done -rm -rf RPMS THIS.TCL.SPEC # | | | | | 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 |
mkdir -p RPMS/$$platform && \
rpmbuild -bb THIS.TCL.SPEC && \
mv RPMS/$$platform/*.rpm .; \
done
-rm -rf RPMS THIS.TCL.SPEC
#
# 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
DISTNAME = tcl${VERSION}${PATCH_LEVEL}
ZIPNAME = tcl${MAJOR_VERSION}${MINOR_VERSION}${PATCH_LEVEL}-src.zip
DISTDIR = $(DISTROOT)/$(DISTNAME)
DIST_INSTALL_DATA = CPPROG='cp -p' $(INSTALL) -m 644
|
| ︙ | ︙ |
Changes to unix/tclUnixInit.c.
| ︙ | ︙ | |||
984 985 986 987 988 989 990 | * TclpFindVariable -- * * Locate the entry in environ for a given name. On Unix this routine is * case sensetive, on Windows this matches mixed case. * * Results: * The return value is the index in environ of an entry with the name | | | | 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 |
* TclpFindVariable --
*
* Locate the entry in environ for a given name. On Unix this routine is
* case sensetive, on Windows this matches mixed case.
*
* Results:
* The return value is the index in environ of an entry with the name
* "name", or TCL_INDEX_NONE if there is no such entry. The integer at *lengthPtr is
* filled in with the length of name (if a matching entry is found) or
* the length of the environ array (if no matching entry is found).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
size_t
TclpFindVariable(
const char *name, /* Name of desired environment variable
* (native). */
size_t *lengthPtr) /* Used to return length of name (for
* successful searches) or number of non-NULL
* entries in environ (for unsuccessful
* searches). */
{
size_t i, result = TCL_INDEX_NONE;
const char *env, *p1, *p2;
Tcl_DString envString;
Tcl_DStringInit(&envString);
for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
p1 = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
p2 = name;
|
| ︙ | ︙ |
Changes to win/Makefile.in.
| ︙ | ︙ | |||
596 597 598 599 600 601 602 603 604 605 606 607 608 609 |
${TEST_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS}
@$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE}
@MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
$(COPY) tclsh.exe.manifest ${TEST_DLL_FILE}.manifest
${TEST_EXE_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} tclTestMain.${OBJEXT}
@$(RM) ${TEST_EXE_FILE}
$(CC) $(CFLAGS) $(TCLTEST_OBJS) tclTestMain.$(OBJEXT) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
$(COPY) tclsh.exe.manifest ${TEST_EXE_FILE}.manifest
# use pre-built zlib1.dll
${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE}
@if test "@ZLIB_LIBS@set" != "${ZLIB_DIR_NATIVE}/win32/zdll.libset" ; then \
| > | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 |
${TEST_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS}
@$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE}
@MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
$(COPY) tclsh.exe.manifest ${TEST_DLL_FILE}.manifest
${TEST_EXE_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} tclTestMain.${OBJEXT}
@$(RM) ${TEST_EXE_FILE}
@$(RM) $(ROOT_DIR_NATIVE)/tests/safe-stock86.test
$(CC) $(CFLAGS) $(TCLTEST_OBJS) tclTestMain.$(OBJEXT) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
$(COPY) tclsh.exe.manifest ${TEST_EXE_FILE}.manifest
# use pre-built zlib1.dll
${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE}
@if test "@ZLIB_LIBS@set" != "${ZLIB_DIR_NATIVE}/win32/zdll.libset" ; then \
|
| ︙ | ︙ | |||
887 888 889 890 891 892 893 |
$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \
done;
@echo "Installing package cookiejar 0.2"
@for j in $(ROOT_DIR)/library/cookiejar/*.{tcl,txt.gz}; \
do \
$(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
done;
| | | | 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 |
$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \
done;
@echo "Installing package cookiejar 0.2"
@for j in $(ROOT_DIR)/library/cookiejar/*.{tcl,txt.gz}; \
do \
$(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
done;
@echo "Installing package http 2.9.5 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/9.0/http-2.9.5.tm";
@echo "Installing package opt 0.4.7";
@for j in $(ROOT_DIR)/library/opt/*.tcl; \
do \
$(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
done;
@echo "Installing package msgcat 1.7.1 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl "$(MODULE_INSTALL_DIR)/9.0/msgcat-1.7.1.tm";
|
| ︙ | ︙ |
Changes to win/nmakehlp.c.
| ︙ | ︙ | |||
704 705 706 707 708 709 710 |
static int
QualifyPath(
const char *szPath)
{
char szCwd[MAX_PATH + 1];
| | | 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 |
static int
QualifyPath(
const char *szPath)
{
char szCwd[MAX_PATH + 1];
GetFullPathName(szPath, sizeof(szCwd)-1, szCwd, NULL);
printf("%s\n", szCwd);
return 0;
}
/*
* Implements LocateDependency for a single directory. See that command
* for an explanation.
|
| ︙ | ︙ |
Changes to win/rules.vc.
| ︙ | ︙ | |||
510 511 512 513 514 515 516 | ################################################################ # 4. Build the nmakehlp program # This is a helper app we need to overcome nmake's limiting # environment. We will call out to it to get various bits of # information about supported compiler options etc. # # Tcl itself will always use the nmakehlp.c program which is | | | 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 | ################################################################ # 4. Build the nmakehlp program # This is a helper app we need to overcome nmake's limiting # environment. We will call out to it to get various bits of # information about supported compiler options etc. # # Tcl itself will always use the nmakehlp.c program which is # 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 # otherwise. In the latter case, they would also be using their own # rules.vc. Note that older versions of Tcl do not install nmakehlp.c # or rules.vc. # |
| ︙ | ︙ | |||
1665 1666 1667 1668 1669 1670 1671 |
@if exist $(LIBDIR) for %f in ("$(LIBDIR)\*.tcl") do @$(COPY) %f "$(OUT_DIR)"
$(DEBUGGER) $(TCLSH)
# Generation of Windows version resource
!ifdef RCFILE
# Note: don't use $** in below rule because there may be other dependencies
| | | 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 |
@if exist $(LIBDIR) for %f in ("$(LIBDIR)\*.tcl") do @$(COPY) %f "$(OUT_DIR)"
$(DEBUGGER) $(TCLSH)
# Generation of Windows version resource
!ifdef RCFILE
# Note: don't use $** in below rule because there may be other dependencies
# and only the "main" rc must be passed to the resource compiler
$(TMP_DIR)\$(PROJECT).res: $(RCDIR)\$(PROJECT).rc
$(RESCMD) $(RCDIR)\$(PROJECT).rc
!else
# If parent makefile has not defined a resource definition file,
# we will generate one from standard template.
|
| ︙ | ︙ | |||
1719 1720 1721 1722 1723 1724 1725 | !ifndef DISABLE_IMPLICIT_RULES DISABLE_IMPLICIT_RULES = 0 !endif !if !$(DISABLE_IMPLICIT_RULES) # Implicit rule definitions - only for building library objects. For stubs and | | | 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 |
!ifndef DISABLE_IMPLICIT_RULES
DISABLE_IMPLICIT_RULES = 0
!endif
!if !$(DISABLE_IMPLICIT_RULES)
# Implicit rule definitions - only for building library objects. For stubs and
# main application, the makefile should define explicit rules.
{$(ROOT)}.c{$(TMP_DIR)}.obj::
$(CCPKGCMD) @<<
$<
<<
{$(WIN_DIR)}.c{$(TMP_DIR)}.obj::
|
| ︙ | ︙ |
Changes to win/tclWinInit.c.
| ︙ | ︙ | |||
610 611 612 613 614 615 616 | * TclpFindVariable -- * * Locate the entry in environ for a given name. On Unix this routine is * case sensitive, on Windows this matches mixed case. * * Results: * The return value is the index in environ of an entry with the name | | | 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 | * TclpFindVariable -- * * Locate the entry in environ for a given name. On Unix this routine is * case sensitive, on Windows this matches mixed case. * * Results: * The return value is the index in environ of an entry with the name * "name", or TCL_INDEX_NONE if there is no such entry. The integer * at *lengthPtr is filled in with the length of name (if a matching * entry is found) or the length of the environ array (if no * matching entry is found). * * Side effects: * None. * |
| ︙ | ︙ | |||
633 634 635 636 637 638 639 |
const char *name, /* Name of desired environment variable
* (UTF-8). */
size_t *lengthPtr) /* Used to return length of name (for
* successful searches) or number of non-NULL
* entries in environ (for unsuccessful
* searches). */
{
| | | 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 |
const char *name, /* Name of desired environment variable
* (UTF-8). */
size_t *lengthPtr) /* Used to return length of name (for
* successful searches) or number of non-NULL
* entries in environ (for unsuccessful
* searches). */
{
size_t i, length, result = TCL_INDEX_NONE;
const WCHAR *env;
const char *p1, *p2;
char *envUpper, *nameUpper;
Tcl_DString envString;
/*
* Convert the name to all upper case for the case insensitive comparison.
|
| ︙ | ︙ |
Changes to win/tclWinPipe.c.
| ︙ | ︙ | |||
847 848 849 850 851 852 853 | * * Given a HANDLE to a child process, return the process id for that * child process. * * Results: * Returns the process id for the child process. If the pid was not known * by Tcl, either because the pid was not created by Tcl or the child | | | 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 | * * Given a HANDLE to a child process, return the process id for that * child process. * * Results: * Returns the process id for the child process. If the pid was not known * by Tcl, either because the pid was not created by Tcl or the child * process has already been reaped, TCL_INDEX_NONE is returned. * * Side effects: * None. * *-------------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
871 872 873 874 875 876 877 |
for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
if (infoPtr->dwProcessId == (size_t) pid) {
Tcl_MutexUnlock(&pipeMutex);
return infoPtr->dwProcessId;
}
}
Tcl_MutexUnlock(&pipeMutex);
| | | 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 |
for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
if (infoPtr->dwProcessId == (size_t) pid) {
Tcl_MutexUnlock(&pipeMutex);
return infoPtr->dwProcessId;
}
}
Tcl_MutexUnlock(&pipeMutex);
return TCL_INDEX_NONE;
}
/*
*----------------------------------------------------------------------
*
* TclpCreateProcess --
*
|
| ︙ | ︙ |