Check-in [51c350e0e9]
Not logged in

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: 51c350e0e96def620bf7d3416f03fd44acd49ae4bbac1d088706c9e6a2f0e67d
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
Unified Diff Ignore Whitespace Patch
Changes to .fossil-settings/binary-glob.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
compat/zlib/win32/zdll.lib
compat/zlib/win32/zlib1.dll
compat/zlib/win64/zdll.lib
compat/zlib/win64/zlib1.dll
compat/zlib/win64/libz.dll.a
compat/zlib/zlib.3.pdf
compat/zlib/win32/zdll.lib
compat/zlib/win32/zlib1.dll
compat/zlib/win64/zdll.lib
compat/zlib/win64/zlib1.dll
compat/zlib/win64/libz.dll.a
compat/zlib/zlib.3.pdf
libtommath/win32/tommath.lib
libtommath/win32/libtommath.dll
libtommath/win64/tommath.lib
libtommath/win64/libtommath.dll
libtommath/win64/libtommath.dll.a
*.a
*.bmp
*.dll
*.exe
*.gif
*.gz
*.jpg
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























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
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/gen.pl
libtommath/*.sh
libtommath/doc/*
libtommath/tombc/*
libtommath/pre_gen/*
libtommath/pics/*
libtommath/mtest/*
libtommath/logs/*







|







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
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: bionic
      compiler: gcc
      env:
        - BUILD_DIR=unix
    - name: "Linux/GCC/Shared: UTF_MAX=3"
      os: linux
      dist: bionic
      compiler: gcc
      env:
        - BUILD_DIR=unix
        - CFGOPT="CFLAGS=-DTCL_UTF_MAX=3"
    - name: "Linux/GCC/Shared: NO_DEPRECATED"
      os: linux
      dist: bionic
      compiler: gcc
      env:
        - BUILD_DIR=unix
        - CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1"
    - name: "Linux/GCC/Static"
      os: linux
      dist: bionic
      compiler: gcc
      env:
        - CFGOPT="--disable-shared"
        - BUILD_DIR=unix
    - name: "Linux/GCC/Debug"
      os: linux
      dist: bionic
      compiler: gcc
      env:
        - BUILD_DIR=unix
        - CFGOPT="--enable-symbols"
    - name: "Linux/GCC/Mem-Debug"
      os: linux
      dist: bionic
      compiler: gcc
      env:
        - BUILD_DIR=unix
        - CFGOPT="--enable-symbols=mem"
# C++ build.
    - name: "Linux/G++/Shared"
      os: linux
      dist: bionic
      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: bionic
      compiler: gcc-7
      addons:
        apt:
          sources:
            - ubuntu-toolchain-r-test
          packages:
            - g++-7







|





|






|






|






|






|







|







|







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
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: bionic
      compiler: clang
      env:
        - BUILD_DIR=unix
    - name: "Linux/Clang/Static"
      os: linux
      dist: bionic
      compiler: clang
      env:
        - CFGOPT="--disable-shared"
        - BUILD_DIR=unix
    - name: "Linux/Clang/Debug"
      os: linux
      dist: bionic
      compiler: clang
      env:
        - BUILD_DIR=unix
        - CFGOPT="--enable-symbols"
    - name: "Linux/Clang/Mem-Debug"
      os: linux
      dist: bionic
      compiler: clang
      env:
        - BUILD_DIR=unix
        - CFGOPT="--enable-symbols=mem"
# Testing on Mac, various styles
    - name: "macOS/Clang/Xcode 11.5/Shared"
      os: osx
      osx_image: xcode11.5
      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.5/Shared/Unix-like"
      os: osx
      osx_image: xcode11.5
      env:
        - BUILD_DIR=unix
    - name: "macOS/Clang/Xcode 11.5/Shared/libtommath"
      os: osx
      osx_image: xcode11.5
      env:
        - BUILD_DIR=macosx
      install: []
      script: *mactest
      addons:
        homebrew:
          packages:
            - libtommath
    - name: "macOS/Clang++/Xcode 11.5/Shared"
      os: osx
      osx_image: xcode11.5
      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"







|





|






|






|





|

|







|

|


|

|








|

|







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
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: bionic
      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: bionic
      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"







|













|







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
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: bionic
      compiler: gcc
      env:
        - BUILD_DIR=unix
      script:
        - make dist
before_install:
  - cd ${BUILD_DIR}







|







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
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_CreateSlave, Tcl_GetSlave, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands
.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_CreateSlave\fR(\fIinterp, name, isSafe\fR)
.sp
Tcl_Interp *
\fBTcl_GetSlave\fR(\fIinterp, name\fR)
.sp
Tcl_Interp *
\fBTcl_GetMaster\fR(\fIinterp\fR)
.sp
int
\fBTcl_GetInterpPath\fR(\fIinterp, slaveInterp\fR)
.sp
int
\fBTcl_CreateAlias\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd,
                argc, argv\fR)
.sp
int
\fBTcl_CreateAliasObj\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd,
                   objc, objv\fR)
.sp
int
\fBTcl_GetAlias\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr,
             argcPtr, argvPtr\fR)
.sp
int
\fBTcl_GetAliasObj\fR(\fIinterp, slaveCmd, 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 slave interpreter to create or manipulate.
.AP int isSafe in
If non-zero, a
.QW safe
slave that is suitable for running untrusted code
is created, otherwise a trusted slave is created.
.AP Tcl_Interp *slaveInterp in
Interpreter to use for creating the source command for an alias (see
below).
.AP "const char" *slaveCmd 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.










|











|


|


|


|


|



|



|



|












|



|
|
|


|







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
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_CreateSlave\fR creates a new interpreter as a slave of \fIinterp\fR.
It also creates a slave command named \fIslaveName\fR in \fIinterp\fR which
allows \fIinterp\fR to manipulate the new slave.
If \fIisSafe\fR is zero, the command creates a trusted slave in which Tcl
code has access to all the Tcl commands.
If it is \fB1\fR, the command creates a
.QW safe
slave in which Tcl code has access only to set of Tcl commands defined as
.QW "Safe Tcl" ;
see the manual entry for the Tcl \fBinterp\fR command for details.
If the creation of the new slave interpreter failed, \fBNULL\fR is returned.
.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_CreateSlave\fR
may be a better choice, since it creates interpreters in a known-safe state.
.PP
\fBTcl_GetSlave\fR returns a pointer to a slave interpreter of
\fIinterp\fR. The slave interpreter is identified by \fIslaveName\fR.
If no such slave interpreter exists, \fBNULL\fR is returned.
.PP
\fBTcl_GetMaster\fR returns a pointer to the master interpreter of
\fIinterp\fR. If \fIinterp\fR has no master (it is a
top-level interpreter) then \fBNULL\fR is returned.
.PP
\fBTcl_GetInterpPath\fR stores in the result of \fIinterp\fR
the relative path between \fIinterp\fR and \fIslaveInterp\fR;
\fIslaveInterp\fR must be a slave of \fIinterp\fR. If the computation
of the relative path succeeds, \fBTCL_OK\fR is returned, else
\fBTCL_ERROR\fR is returned and an error message is stored as the
result of \fIinterp\fR.
.PP
\fBTcl_CreateAlias\fR creates a command named \fIslaveCmd\fR in
\fIslaveInterp\fR that when invoked, will cause the command \fItargetCmd\fR
to be invoked in \fItargetInterp\fR. The arguments specified by the strings
contained in \fIargv\fR are always prepended to any arguments supplied in the
invocation of \fIslaveCmd\fR and passed to \fItargetCmd\fR.
This operation returns \fBTCL_OK\fR if it succeeds, or \fBTCL_ERROR\fR if
it fails; in that case, an error message is left in the value result
of \fIslaveInterp\fR.
Note that there are no restrictions on the ancestry relationship (as
created by \fBTcl_CreateSlave\fR) between \fIslaveInterp\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







|
|
|
|



|


|















|


|
|
|

|
|



|
|




|
|


|


|

|







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
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,
master, slave







|
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
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 "master list"
of volumes
or not (if not, they generate the list on the fly and pass it to Tcl
with a reference count of 1 and then forget about the list, if yes, then
they simply increment the reference count of their master list and pass it
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







|



|







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

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
.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.

The internal representation is modified to hold the index of the matching
table entry.
.AP "const char *const" *tablePtr in
An array of null-terminated strings.  The end of the array is marked
by a NULL string pointer.

Note that references to the \fItablePtr\fR may be retained in the
internal representation of \fIobjPtr\fR, so this should represent the
address of a statically-allocated array.
.AP "const void" *structTablePtr in
An array of arbitrary type, typically some \fBstruct\fR type.
The first member of the structure must be a null-terminated string.
The size of the structure is given by \fIoffset\fR.

Note that references to the \fIstructTablePtr\fR may be retained in the
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 bit that is currently defined is \fBTCL_EXACT\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,







>
|




>
|






>
|










|
>







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

79
80
81
82
83
84
85
86


87
88
89
90
91
92
93
94
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 \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.  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







>
|







>
>
|







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
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 a master 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







|







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
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 master 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







|







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
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 master 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 master 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







|













|







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
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 master interpreter.  If that variable exists and holds the
name of a readable file, the contents of that file are evaluated
in the master interpreter.  Then interactive operations begin,
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
master 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







|

|







|







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
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 \fImaster\fR
and the new interpreter is called a \fIslave\fR.
A master can create any number of slaves, and each slave can
itself create additional slaves for which it is master, resulting
in a hierarchy of interpreters.
.PP
Each interpreter is independent from the others: it has its own name
space for commands, procedures, and global variables.
A master interpreter may create connections between its slaves and
itself using a mechanism called an \fIalias\fR.  An \fIalias\fR is
a command in a slave interpreter which, when invoked, causes a
command to be invoked in its master interpreter or in another slave
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 slave 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 slave interpreter and its master.
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 master. Interpreter names are relative to the
interpreter in which they are used. For example, if
.QW \fBa\fR
is a slave of the current interpreter and it has a slave
.QW \fBa1\fR ,
which in turn has a slave
.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 master (ancestor) interpreter by name in a
slave interpreter except through aliases. Also, there is no global name by
which one can refer to the first interpreter created in an application.
Both restrictions are motivated by safety concerns.
.SH "THE INTERP COMMAND"
.PP
The \fBinterp\fR command is used to create, delete, and manipulate
slave interpreters, and to share or transfer
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
slave is different from \fIsrcToken\fR).
.TP
\fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcToken\fR \fB{}\fR
.
Deletes the alias for \fIsrcToken\fR in the slave interpreter identified by
\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 slave and another (see the
\fBalias\fR slave command below for creating aliases between a slave
and its master).  In this command, either of the slave interpreters
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 slave of interpreter
.QW \fBa\fR ,
which is a slave 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







|
|
|
|




|

|
|










|












|





|


|

|











|
|





|









|



|







|
|
|








|

|







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
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 slave interpreter identified by \fIpath\fR and a new command,
called a \fIslave command\fR. The name of the slave command is the last
component of \fIpath\fR. The new slave interpreter and the slave command
are created in the interpreter identified by the path obtained by removing
the last component from \fIpath\fR. For example, if \fIpath\fR is \fBa b
c\fR then a new slave interpreter and slave command named \fBc\fR are
created in the interpreter identified by the path \fBa b\fR.
The slave command may be used to manipulate the new interpreter as
described below. If \fIpath\fR is omitted, Tcl creates a unique name of the
form \fBinterp\fIx\fR, where \fIx\fR is an integer, and uses it for the
interpreter and the slave command. If the \fB\-safe\fR switch is specified
(or if the master interpreter is a safe interpreter), the new slave
interpreter will be created as a safe interpreter with limited
functionality; otherwise the slave will include the full set of Tcl
built-in commands and variables. The \fB\-\|\-\fR switch can be used to
mark the end of switches;  it may be needed if \fIpath\fR is an unusual
value such as \fB\-safe\fR. The result of the command is the name of the
new interpreter. The name of a slave interpreter must be unique among all
the slaves for its master;  an error occurs if a slave interpreter by the
given name already exists in this master.
The initial recursion limit of the slave interpreter is set to the
current recursion limit of its parent interpreter.
.TP
\fBinterp\fR \fBdebug \fIpath\fR ?\fB\-frame\fR ?\fIbool\fR??
.
Controls whether frame-level stack information is captured in the
slave interpreter identified by \fIpath\fR.  If no arguments are
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







|
|
|


|

|


|
|

|



|
|
|
|





|







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
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 slaves. The
command also deletes the slave 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 slave interpreter identified by \fIpath\fR. The result
of this evaluation (including all \fBreturn\fR options,
such as \fB\-errorinfo\fR and \fB\-errorcode\fR information, if an
error occurs) is returned to the invoking interpreter.
Note that the script will be executed in the current context stack frame of the
\fIpath\fR interpreter; this is so that the implementations (in a master
interpreter) of aliases in a slave interpreter can execute scripts in
the slave that find out information about the slave's current state
and stack frame.
.TP
\fBinterp exists \fIpath\fR
.
Returns \fB1\fR if a slave interpreter by the specified \fIpath\fR
exists in this master, \fB0\fR otherwise. If \fIpath\fR is omitted, the
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 ::),







|
|







|




|
|
|




|
|







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
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 slaves from fooling a master 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.







|







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
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 \fBslaves\fR ?\fIpath\fR?
.
Returns a Tcl list of the names of all the slave 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 "SLAVE COMMAND"
.PP
For each slave interpreter created with the \fBinterp\fR command, a
new Tcl command is created in the master interpreter with the same
name as the new interpreter. This command may be used to invoke
various operations on the interpreter.  It has the following
general form:
.PP
.CS
\fIslave command \fR?\fIarg arg ...\fR?
.CE
.PP
\fISlave\fR is the name of the interpreter, and \fIcommand\fR
and the \fIarg\fRs determine the exact behavior of the command.
The valid forms of this command are:
.TP
\fIslave \fBaliases\fR
.
Returns a Tcl list whose elements are the tokens of all the
aliases in \fIslave\fR.  The tokens correspond to the values returned when
the aliases were created (which may not be the same
as the current names of the commands).
.TP
\fIslave \fBalias \fIsrcToken\fR
.
Returns a Tcl list whose elements are the \fItargetCmd\fR and
\fIarg\fRs associated with the alias represented by \fIsrcToken\fR
(this is the value returned when the alias was
created; it is possible that the actual source command in the
slave is different from \fIsrcToken\fR).
.TP
\fIslave \fBalias \fIsrcToken \fB{}\fR
.
Deletes the alias for \fIsrcToken\fR in the slave interpreter.
\fIsrcToken\fR refers to the value returned when the alias
was created;  if the source command has been renamed, the renamed
command will be deleted.
.TP
\fIslave \fBalias \fIsrcCmd targetCmd \fR?\fIarg ..\fR?
.
Creates an alias such that whenever \fIsrcCmd\fR is invoked
in \fIslave\fR, \fItargetCmd\fR is invoked in the master.
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
\fIslave \fBbgerror\fR ?\fIcmdPrefix\fR?
.
This command either gets or sets the current background exception handler
for the \fIslave\fR interpreter. If \fIcmdPrefix\fR is
absent, the current background exception handler is returned, and if it is
present, it is a list of words (of minimum length one) that describes
what to set the interpreter's background exception handler to. See the
\fBBACKGROUND EXCEPTION HANDLING\fR section for more details.
.TP
\fIslave \fBeval \fIarg \fR?\fIarg ..\fR?
.
This command concatenates all of the \fIarg\fR arguments in
the same fashion as the \fBconcat\fR command, then evaluates
the resulting string as a Tcl script in \fIslave\fR.
The result of this evaluation (including all \fBreturn\fR options,
such as \fB\-errorinfo\fR and \fB\-errorcode\fR information, if an
error occurs) is returned to the invoking interpreter.
Note that the script will be executed in the current context stack frame
of \fIslave\fR; this is so that the implementations (in a master
interpreter) of aliases in a slave interpreter can execute scripts in
the slave that find out information about the slave's current state
and stack frame.
.TP
\fIslave \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR?
.
This command exposes the hidden command \fIhiddenName\fR, eventually bringing
it back under a new \fIexposedCmdName\fR name (this name is currently
accepted only if it is a valid global name space name without any ::),
in \fIslave\fR.
If an exposed command with the targeted name already exists, this command
fails.
For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below.
.TP
\fIslave \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR?
.
This command hides the exposed command \fIexposedCmdName\fR, renaming it to
the hidden command \fIhiddenCmdName\fR, or keeping the same name if the
argument is not given, in the \fIslave\fR interpreter.
If a hidden command with the targeted name already exists, this command
fails.
Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can
not contain namespace qualifiers, or an error is raised.
Commands to be hidden are looked up in the global
namespace even if the current namespace is not the global one. This
prevents slaves from fooling a master interpreter into hiding the wrong
command, by making the current namespace be different from the global one.
For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below.
.TP
\fIslave \fBhidden\fR
.
Returns a list of the names of all hidden commands in \fIslave\fR.
.TP
\fIslave \fBinvokehidden\fR ?\fI\-option ...\fR? \fIhiddenName \fR?\fIarg ..\fR?
.
This command invokes the hidden command \fIhiddenName\fR with the
supplied arguments, in \fIslave\fR. No substitutions or evaluations are
applied to the arguments. Three \fI\-option\fRs are supported, all
of which start with \fB\-\fR: \fB\-namespace\fR (which takes a single
argument afterwards, \fInsName\fR), \fB\-global\fR, and \fB\-\|\-\fR.
If the \fB\-namespace\fR flag is given, the hidden command is invoked in
the specified namespace in the slave.
If the \fB\-global\fR flag is given, the command is invoked at the global
level in the slave; otherwise it is invoked at the current call frame and
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 \fIslave\fR.
For more details on hidden commands,
see \fBHIDDEN COMMANDS\fR, below.
.TP
\fIslave \fBissafe\fR
.
Returns  \fB1\fR if the slave interpreter is safe, \fB0\fR otherwise.
.TP
\fIslave \fBlimit\fR \fIlimitType\fR ?\fI\-option\fR? ?\fIvalue\fR \fI...\fR?
.
Sets up, manipulates and queries the configuration of the resource
limit \fIlimitType\fR for the slave interpreter.  If no \fI\-option\fR
is specified, return the current configuration of the limit.  If
\fI\-option\fR is the sole argument, return the value of that option.
Otherwise, a list of \fI\-option\fR/\fIvalue\fR argument pairs must
supplied. See \fBRESOURCE LIMITS\fR below for a more detailed explanation of
what limits and options are supported.
.TP
\fIslave \fBmarktrusted\fR
.
Marks the slave interpreter as trusted. Can only be invoked by a
trusted interpreter. This command does not expose any hidden
commands in the slave interpreter. The command has no effect if the slave
is already trusted.
.TP
\fIslave\fR \fBrecursionlimit\fR ?\fInewlimit\fR?
.
Returns the maximum allowable nesting depth for the \fIslave\fR interpreter.
If \fInewlimit\fR is specified, the recursion limit in \fIslave\fR will be
set so that nesting of more than \fInewlimit\fR calls to \fBTcl_Eval()\fR
and related procedures in \fIslave\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







|

|



















|

|
|





|


|



|


|



|





|

|

|




|


|








|


|





|



|




|
|
|


|




|




|



|






|



|

|

|


|




|

|







|



|

|

|


|






|

|

|


|

|
|

|







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
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 master interpreter which check their arguments carefully
and provide restricted access to a safe subset of facilities.
For example, file creation might be allowed in a particular subdirectory
and subprocess invocation might be allowed for a carefully selected and
fixed set of programs.
.PP
A safe interpreter is created by specifying the \fB\-safe\fR switch
to the \fBinterp create\fR command.  Furthermore, any slave created
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







|






|







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
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 when an untrusted script is executing
in a safe slave and the target of the alias is a trusted
master.  The most important thing in guaranteeing safety is to
ensure that information passed from the slave to the master is
never evaluated or substituted in the master;  if this were to
occur, it would enable an evil script in the slave to invoke
arbitrary functions in the master, which would compromise security.
.PP
When the source for an alias is invoked in the slave interpreter, the
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







|
|
|
|
|
|
|

|







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
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 slave interpreter could execute arbitrary
code in the master.  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







|
|







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
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 slave interpreter can be invoked in the body of
procedures called in the master during alias invocation. For example, an
alias for \fBsource\fR could be created in a slave interpreter. When it is
invoked in the slave interpreter, a procedure is called in the master
interpreter to check that the operation is allowable (e.g. it asks to
source a file that the slave interpreter is allowed to access). The
procedure then it invokes the hidden \fBsource\fR command in the slave
interpreter to actually source in the contents of the file. Note that two
commands named \fBsource\fR exist in the slave interpreter: the alias, and
the hidden command.
.PP
Because a master interpreter may invoke a hidden command as part of
handling an alias invocation, great care must be taken to avoid evaluating
any arguments passed in through the alias invocation.
Otherwise, malicious slave interpreters could cause a trusted master
interpreter to execute dangerous commands on their behalf. See the section
on \fBALIAS INVOCATION\fR for a more complete discussion of this topic.
To help avoid this problem, no substitutions or evaluations are
applied to arguments of \fBinterp invokehidden\fR.
.PP
Safe interpreters are not allowed to invoke hidden commands in themselves
or in their descendants. This prevents safe slaves from gaining access to
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 slaves from fooling a master interpreter into hiding the wrong
command, by making the current namespace be different from the global one.
.SH "RESOURCE LIMITS"
.PP
Every interpreter has two kinds of resource limits that may be imposed by any
master interpreter upon its slaves. Command limits (of type \fBcommand\fR)
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 master 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.







|
|
|
|

|
|

|


|


|






|


















|




|








|







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
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 slave
interpreter, that slave interpreter will have resource limits imposed on it
that are at least as restrictive as the limits on the creating master
interpreter. If the master interpreter of the limited master wishes to relax
these conditions, it should hide the \fBinterp\fR command in the child and
then use aliases and the \fBinterp invokehidden\fR subcommand to provide such
access as it chooses to the \fBinterp\fR command to the limited master as
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







|
|
|
|


|







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
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_CreateSlave(3), Tcl_Eval(3), Tcl_BackgroundException(3)
.SH KEYWORDS
alias, master interpreter, safe interpreter, slave interpreter
'\"Local Variables:
'\"mode: nroff
'\"End:







|

|



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
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
slave 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)







|







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
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 slave
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







|







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
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 slave 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.







|







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
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 ?\fIslave\fR? ?\fIoptions...\fR?
.sp
\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR?
.sp
\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR?
.sp
\fB::safe::interpDelete\fR \fIslave\fR
.sp
\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR
.sp
\fB::safe::interpFindInAccessPath\fR \fIslave\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?













|

|

|

|

|

|







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
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
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 master 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
master interpreter transparently
translates the token into a real directory name and executes the
requested operation (see the section \fBSECURITY\fR below for details).
Different levels of security can be selected by using the optional flags
of the commands described below.
.PP
All commands provided in the master interpreter by Safe Tcl reside in
the \fBsafe\fR namespace.
.SH COMMANDS
The following commands are provided in the master interpreter:
.TP
\fB::safe::interpCreate\fR ?\fIslave\fR? ?\fIoptions...\fR?
Creates a safe interpreter, installs the aliases described in the section
\fBALIASES\fR and initializes the auto-loading and package mechanism as
specified by the supplied \fIoptions\fR.
See the \fBOPTIONS\fR section below for a description of the
optional arguments.
If the \fIslave\fR argument is omitted, a name will be generated.
\fB::safe::interpCreate\fR always returns the interpreter name.






.TP
\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR?
This command is similar to \fBinterpCreate\fR except it that does not
create the safe interpreter. \fIslave\fR must have been created by some
other means, like \fBinterp create\fR \fB\-safe\fR.


.TP
\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR?
If no \fIoptions\fR are given, returns the settings for all options for the
named safe interpreter as a list of options and their current values
for that \fIslave\fR.
If a single additional argument is provided,
it will return a list of 2 elements \fIname\fR and \fIvalue\fR where
\fIname\fR is the full name of that option and \fIvalue\fR the current value
for that option and the \fIslave\fR.
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 \fIslave\fR
Deletes the safe interpreter and cleans up the corresponding
master interpreter data structures.
If a \fIdeleteHook\fR script was specified for this interpreter it is
evaluated before the interpreter is deleted, with the name of the
interpreter as an additional argument.
.TP
\fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR
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
$slave eval [list set tk_library \e
      [::safe::interpFindInAccessPath $name $tk_library]]
.CE
.RE
.TP
\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR
This command adds \fIdirectory\fR to the virtual path maintained for the
safe interpreter in the master, and returns the token that can be used in
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
$slave 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.







|








|





|


|

|





|

>
>
>
>
>
>

|

|
|
>
>

|


|



|



















|

|




|







|




|

|







|







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
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
.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 slave interp10 : Created
NOTICE for slave interp10 : Setting accessPath=(/foo/bar) staticsok=1 nestedok=0 deletehook=()
NOTICE for slave interp10 : auto_path in interp10 has been set to {$p(:0:)}
ERROR for slave interp10 : /foo/bar/init.tcl: no such file or directory
.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
master 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 :







|
|
|
|















|







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
219
220
221
222
223
224
225
226
\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 master 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:







|







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
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
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 master interpreter.
This virtual path system is maintained in the master 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 slave
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).







|
|








|







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
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
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 slave \fBauto_path\fR and the first element of that list will be set as
the \fBtcl_library\fR for that slave.
.PP
If the access path argument is not given or is the empty list,
the default behavior is to let the slave access the same packages
as the master has access to (Or to be more precise:
only packages written in Tcl (which by definition cannot be dangerous
as they run in the slave interpreter) and C extensions that
provides a _SafeInit entry point). For that purpose, the master's
\fBauto_path\fR will be used to construct the slave access path.
In order that the slave successfully loads the Tcl library files
(which includes the auto-loading mechanism itself) the \fBtcl_library\fR will be
added or moved to the first position if necessary, in the
slave access path, so the slave
\fBtcl_library\fR will be the same as the master's (its real
path will still be invisible to the slave though).
In order that auto-loading works the same for the slave and
the master in this by default case, the first-level
sub directories of each directory in the master \fBauto_path\fR will
also be added (if not already included) to the slave access path.
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, master interpreter, safe
interpreter, slave interpreter, source
'\" Local Variables:
'\" mode: nroff
'\" End:







|
|


|
|

|
|
|
|


|
|
|
|
|
|
|












|
|



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
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 master 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







|







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
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 master process can continue
with the rest of the test suite.  In multi-process operation,
the configuration of \fBtcltest\fR in the master process is
passed to the child processes as command line arguments,
with the exception of \fBconfigure \-outfile\fR.  The
\fBrunAllTests\fR command in the
master process collects all output from the child processes
and collates their results into one master report.  Any
reports of individual test failures, or messages requested
by a \fBconfigure \-verbose\fR setting are passed directly
on to \fBoutputChannel\fR by the master process.
.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







|

|



|
|


|







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
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 master \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.2
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}







|










|







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
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 master script:
.RS
.PP
.CS
package require Tcl 8.4
package require tcltest 2.2
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







|



|
|







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
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 master malloced area, or NULL */
};

#define	WORK	1		/* number of work bitvectors needed */

/*
 * Setup for non-malloc allocation for small cases.
 */







|







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
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 *slave, const char *slaveCmd,
	    Tcl_Interp *target, const char *targetCmd, int argc,
	    const char *const *argv)
}
declare 87 {
    int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd,
	    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)
}







|




|







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
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_CreateSlave(Tcl_Interp *interp, const char *slaveName,
	    int isSafe)
}
declare 98 {
    Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds,
	    Tcl_TimerProc *proc, void *clientData)
}
declare 99 {







|







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
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 *slaveCmd,
	    Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
	    int *argcPtr, const char ***argvPtr)
}
declare 149 {
    int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd,
	    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)
}







|




|







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
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 *slaveInterp)
}
declare 164 {
    Tcl_Interp *Tcl_GetMaster(Tcl_Interp *interp)
}
declare 165 {
    const char *Tcl_GetNameOfExecutable(void)
}
declare 166 {
    Tcl_Obj *Tcl_GetObjResult(Tcl_Interp *interp)
}







|


|







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
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_GetSlave(Tcl_Interp *interp, const char *slaveName)
}
declare 173 {
    Tcl_Channel Tcl_GetStdChannel(int type)
}
# Removed in 9.0, replaced by macro.
#declare 174 {
#    const char *Tcl_GetStringResult(Tcl_Interp *interp)







|







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
819
820


821
822
823

824
825
826
827
828
829
830
 *	that condition.
 */

#define TCL_DONT_USE_BRACES	1
#define TCL_DONT_QUOTE_HASH	8

/*
 * Flag that may be passed to Tcl_GetIndexFromObj to force it to disallow
 * abbreviated strings.


 */

#define TCL_EXACT	1


/*
 *----------------------------------------------------------------------------
 * 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!
 *







|
|
>
>


|
>







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
665
666
667
668
669
670
671
672
    }

    if (commandTypeInit == 0) {
        TclRegisterCommandTypeName(TclObjInterpProc, "proc");
        TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble");
        TclRegisterCommandTypeName(TclAliasObjCmd, "alias");
        TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias");
        TclRegisterCommandTypeName(TclSlaveObjCmd, "interp");
        TclRegisterCommandTypeName(TclInvokeImportedCmd, "import");
        TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object");
        TclRegisterCommandTypeName(TclOOPrivateObjectCmd, "privateObject");
        TclRegisterCommandTypeName(TclOOMyClassObjCmd, "privateClass");
        TclRegisterCommandTypeName(TclNRInterpCoroutine, "coroutine");
    }








|







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
3298
3299
3300
3301
3302
3303
3304
3305
    char *name;

    /*
     * Add the full name of the containing namespace, followed by the "::"
     * separator, and the command name.
     */

    if (cmdPtr != NULL) {
	if (cmdPtr->nsPtr != NULL) {
	    Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
	    if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
		Tcl_AppendToObj(objPtr, "::", 2);
	    }
	}
	if (cmdPtr->hPtr != NULL) {







|







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
3388
3389
3390
3391
3392
3393
3394
3395
     * 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_IS_DELETED) {
	/*
	 * 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]
	 */







|







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
3420
3421
3422
3423
3424
3425
3426
3427
     * 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_IS_DELETED;

    /*
     * Call trace functions for the command being deleted. Then delete its
     * traces.
     */

    cmdPtr->nsPtr->refCount++;







|







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
3450
3451
3452
3453
3454
3455
3456
3457
	    }
	    tracePtr = nextPtr;
	}
	cmdPtr->tracePtr = NULL;
    }

    /*
     * The list of command 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);








|







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
3585
3586
3587
3588
3589
3590
3591
3592
    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_IS_DELETED) 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) {







|







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
3716
3717
3718
3719
3720
3721
3722
3723
	     * 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 slave
	     * interpreters belonging to this one.
	     */

	    TclSetChildCancelFlags((Tcl_Interp *) iPtr,
		    cancelInfo->flags | CANCELED, 0);

	    /*







|







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
3884
3885
3886
3887
3888
3889
3890
3891

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Canceled --
 *
 *	Check if the script in progress has been canceled, i.e.,
 *	Tcl_CancelEval was called for this interpreter or any of its master
 *	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







|







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
4753
4754
4755
4756
4757
4758
4759
4760
    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_IS_DELETED)) {
	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);







|







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
4896
4897
4898
4899
4900
4901
4902
4903
    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 "master 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







|







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
5873
5874
5875
5876
5877
5878
5879
5880
	 * 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 od 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);







|







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
6428
6429
6430
6431
6432
6433
6434
6435
	Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
    }
    return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv);
}

int
TclNRInvoke(
    TCL_UNUSED(ClientData),
    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]. */







|







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
6758
6759
6760
6761
6762
6763
6764
6765
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ExprCeilFunc(
    TCL_UNUSED(ClientData),
    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;







|







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
6798
6799
6800
6801
6802
6803
6804
6805
	Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d)));
    }
    return TCL_OK;
}

static int
ExprFloorFunc(
    TCL_UNUSED(ClientData),
    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;







|







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
6838
6839
6840
6841
6842
6843
6844
6845
	Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d)));
    }
    return TCL_OK;
}

static int
ExprIsqrtFunc(
    TCL_UNUSED(ClientData),
    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;







|







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
6944
6945
6946
6947
6948
6949
6950
6951
    Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
	    "domain error: argument not in valid range", NULL);
    return TCL_ERROR;
}

static int
ExprSqrtFunc(
    TCL_UNUSED(ClientData),
    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;







|







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
7112
7113
7114
7115
7116
7117
7118
7119
    }
    errno = 0;
    return CheckDoubleResult(interp, func(d1, d2));
}

static int
ExprAbsFunc(
    TCL_UNUSED(ClientData),
    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;







|







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
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
#endif
    }
    return TCL_OK;
}

static int
ExprBoolFunc(
    TCL_UNUSED(ClientData),
    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(ClientData),
    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;








|




















|







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
7259
7260
7261
7262
7263
7264
7265
7266
    }
    Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
    return TCL_OK;
}

static int
ExprIntFunc(
    TCL_UNUSED(ClientData),
    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;







|







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
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

    Tcl_GetDoubleFromObj(interp, objv[1], &d);
    return TCL_ERROR;
}

static int
ExprWideFunc(
    TCL_UNUSED(ClientData),
    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(ClientData),
    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;







|




















|







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
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

    Tcl_SetObjResult(interp, res);
    return TCL_OK;
}

static int
ExprMaxFunc(
    TCL_UNUSED(ClientData),
    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(ClientData),
    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(ClientData),
    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;







|










|










|







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
7491
7492
7493
7494
7495
7496
7497
7498
    TclNewDoubleObj(oResult, dResult);
    Tcl_SetObjResult(interp, oResult);
    return TCL_OK;
}

static int
ExprRoundFunc(
    TCL_UNUSED(ClientData),
    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;







|







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
7570
7571
7572
7573
7574
7575
7576
7577

    Tcl_GetDoubleFromObj(interp, objv[1], &d);
    return TCL_ERROR;
}

static int
ExprSrandFunc(
    TCL_UNUSED(ClientData),
    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. */







|







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
7759
7760
7761
7762
7763
7764
7765
7766
#error "unknown or unexpected TCL_FPCLASSIFY_MODE"
#endif /* TCL_FPCLASSIFY_MODE */
#endif /* !fpclassify */
}

static int
ExprIsFiniteFunc(
    TCL_UNUSED(ClientData),
    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;







|







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
7790
7791
7792
7793
7794
7795
7796
7797
    }
    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
    return TCL_OK;
}

static int
ExprIsInfinityFunc(
    TCL_UNUSED(ClientData),
    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;







|







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
7820
7821
7822
7823
7824
7825
7826
7827
    }
    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
    return TCL_OK;
}

static int
ExprIsNaNFunc(
    TCL_UNUSED(ClientData),
    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;







|







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
7850
7851
7852
7853
7854
7855
7856
7857
    }
    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
    return TCL_OK;
}

static int
ExprIsNormalFunc(
    TCL_UNUSED(ClientData),
    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;







|







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
7880
7881
7882
7883
7884
7885
7886
7887
    }
    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
    return TCL_OK;
}

static int
ExprIsSubnormalFunc(
    TCL_UNUSED(ClientData),
    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;







|







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
7910
7911
7912
7913
7914
7915
7916
7917
    }
    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
    return TCL_OK;
}

static int
ExprIsUnorderedFunc(
    TCL_UNUSED(ClientData),
    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;







|







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
7951
7952
7953
7954
7955
7956
7957
7958

    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
    return TCL_OK;
}

static int
FloatClassifyObjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
8060
8061
8062
8063
8064
8065
8066
8067
 *	The 'tcl-probe' DTrace probe is triggered (if it is enabled).
 *
 *----------------------------------------------------------------------
 */

static int
DTraceObjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
8444
8445
8446
8447
8448
8449
8450
8451
 *	updated so that its data[1] field contains the tailcall list.
 *
 *----------------------------------------------------------------------
 */

int
TclNRTailcallObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Interp *iPtr = (Interp *) interp;

    if (objc < 1) {







|







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
8637
8638
8639
8640
8641
8642
8643
8644
    TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
            clientData, NULL, NULL);
    return TCL_OK;
}

int
TclNRYieldToObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
    Tcl_Obj *listPtr, *nsObjPtr;
    Tcl_Namespace *nsPtr = TclGetCurrentNamespace(interp);







|







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
8760
8761
8762
8763
8764
8765
8766
8767
	return result;
    }

    NRE_ASSERT(COR_IS_SUSPENDED(corPtr));
    SAVE_CONTEXT(corPtr->running);
    RESTORE_CONTEXT(corPtr->caller);

    if (cmdPtr->flags & CMD_IS_DELETED) {
	/*
	 * 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);







|







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
8947
8948
8949
8950
8951
8952
8953
8954
 *      Implementation of [::tcl::unsupported::corotype] command.
 *
 *----------------------------------------------------------------------
 */

static int
CoroTypeObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Command *cmdPtr;
    CoroutineData *corPtr;








|







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
9037
9038
9039
9040
9041
9042
9043
9044
        return NULL;
    }
    return (CoroutineData *)cmdPtr->objClientData;
}

static int
TclNRCoroInjectObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    CoroutineData *corPtr;
    ExecEnv *savedEEPtr = iPtr->execEnvPtr;








|







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
9082
9083
9084
9085
9086
9087
9088
9089
    iPtr->execEnvPtr = savedEEPtr;

    return TCL_OK;
}

static int
TclNRCoroProbeObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    CoroutineData *corPtr;
    ExecEnv *savedEEPtr = iPtr->execEnvPtr;
    int numLevels, unused;







|







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
9275
9276
9277
9278
9279
9280
9281
9282
 *      Implementation of [::tcl::unsupported::inject] command.
 *
 *----------------------------------------------------------------------
 */

static int
NRInjectObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    CoroutineData *corPtr;
    ExecEnv *savedEEPtr = iPtr->execEnvPtr;








|







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
9384
9385
9386
9387
9388
9389
9390
9391
 *      description of what this does.
 *
 *----------------------------------------------------------------------
 */

int
TclNRCoroutineObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Command *cmdPtr;
    CoroutineData *corPtr;
    const char *procName, *simpleName;







|







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
9517
9518
9519
9520
9521
9522
9523
9524
9525
9526
9527
9528
9529
9530
9531
9532
9533
9534
9535
9536

/*
 * This is used in the [info] ensemble
 */

int
TclInfoCoroutineCmd(
    TCL_UNUSED(ClientData),
    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_IS_DELETED)) {
	Tcl_Obj *namePtr;

	TclNewObj(namePtr);
	Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, namePtr);
	Tcl_SetObjResult(interp, namePtr);
    }
    return TCL_OK;







|











|







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
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[1];	/* 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)







|







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
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 master, so do not need their
     * own copies of the support routines.
     */

    if (Tcl_IsSafe(interp)) {
	return;
    }








|







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
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_GetSlave(interp, TclGetString(objv[1]));
	if (target == NULL) {
	    return TCL_ERROR;
	}
    }

    iPtr = (Interp *) target;
    Tcl_SetObjResult(interp, iPtr->errorStack);







|







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
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 slave 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 {







|







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
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, Tcl_NewWideIntObj(index));
	}
    } else if (index < 0) {
	/*
	 * Is this superfluous? The result should be a blank object by
	 * default...
	 */








|







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
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(sizeof(ForeachInfo));
    infoPtr->numLists = 1;
    infoPtr->varLists[0] = (ForeachVarList *)Tcl_Alloc(sizeof(ForeachVarList) + 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.







|

|







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
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(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
    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.







|







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
2277
2278
2279
2280
2281
2282
2283
2284
DupDictUpdateInfo(
    ClientData clientData)
{
    DictUpdateInfo *dui1Ptr, *dui2Ptr;
    size_t len;

    dui1Ptr = (DictUpdateInfo *)clientData;
    len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1);
    dui2Ptr = (DictUpdateInfo *)Tcl_Alloc(len);
    memcpy(dui2Ptr, dui1Ptr, len);
    return dui2Ptr;
}

static void
FreeDictUpdateInfo(







|







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
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(sizeof(ForeachInfo)
	    + (numLists - 1) * 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.
     */







|
|







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
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(sizeof(ForeachVarList)
		+ (numVars - 1) * sizeof(int));
	varListPtr->numVars = numVars;
	infoPtr->varLists[i/2] = varListPtr;
	infoPtr->numLists++;

	for (j = 0;  j < numVars;  j++) {
	    Tcl_Obj *varNameObj;
	    const char *bytes;







|
|







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
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(sizeof(ForeachInfo)
	    + 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(sizeof(ForeachVarList)
		+ numVars * sizeof(int));
	dupListPtr->numVars = numVars;
	for (j = 0;  j < numVars;  j++) {
	    dupListPtr->varIndexes[j] =	srcListPtr->varIndexes[j];
	}
	dupPtr->varLists[i] = dupListPtr;
    }







|








|







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
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_GetMaster(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) {







|







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
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) {
	TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
    }
    TclEmitPush(cmdLitIdx, envPtr);
}

void
TclCompileInvocation(







|







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
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[1];		/* 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;







|







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
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[1];/* 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;

/*







|







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
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[1];		/* 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;








|







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
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 *slave,
				const char *slaveCmd, Tcl_Interp *target,
				const char *targetCmd, int argc,
				const char *const *argv);
/* 87 */
EXTERN int		Tcl_CreateAliasObj(Tcl_Interp *slave,
				const char *slaveCmd, Tcl_Interp *target,
				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 */







|
|



|
|







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
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_CreateSlave(Tcl_Interp *interp,
				const char *slaveName, 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 */







|
|







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
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 *slaveCmd,
				Tcl_Interp **targetInterpPtr,
				const char **targetCmdPtr, int *argcPtr,
				const char ***argvPtr);
/* 149 */
EXTERN int		Tcl_GetAliasObj(Tcl_Interp *interp,
				const char *slaveCmd,
				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);







|





|







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
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 *slaveInterp);
/* 164 */
EXTERN Tcl_Interp *	Tcl_GetMaster(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,







|

|







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
513
514
515
516
517
518
519
520
521
/* 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_GetSlave(Tcl_Interp *interp,
				const char *slaveName);
/* 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);







|
<







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
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
    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 *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */
    int (*tcl_CreateAliasObj) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */
    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_CreateSlave) (Tcl_Interp *interp, const char *slaveName, 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 */







|
|









|







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
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
1969
    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 *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */
    int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */
    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 *slaveInterp); /* 163 */
    Tcl_Interp * (*tcl_GetMaster) (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_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 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 */







|
|













|
|















|







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
2644
2645
2646
2647
2648
2649
2650
2651
2652
#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_CreateSlave \
	(tclStubsPtr->tcl_CreateSlave) /* 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 \







|
|







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
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
	(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_GetMaster \
	(tclStubsPtr->tcl_GetMaster) /* 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_GetSlave \
	(tclStubsPtr->tcl_GetSlave) /* 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 */







|
|




















|
|







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
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[1];/* 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







|







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
1995
1996
1997
1998
1999
2000
2001
2002
		Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est));
	    }
	}
	Tcl_Free((void *)argv);
	Tcl_DStringFree(&lineString);
    }

    size = sizeof(EscapeEncodingData) - sizeof(EscapeSubTable)
	    + 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 =







|







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
3165
3166
3167
3168
3169
3170
3171
3172
	    goto cleanup;
	}
	ensemble = (Tcl_Command) cmdPtr;
	goto checkNextWord;
    }

    /*
     * Now we've done the mapping process, can now 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,







|







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
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 needed 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);








|
|
|







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
303
304
305
306
307
308
309
310
 *	Depends on what actions the "bgerror" command takes for the errors.
 *
 *----------------------------------------------------------------------
 */

int
TclDefaultBgErrorHandlerObjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
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 master 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







|







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
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 master 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.
     */







|







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
1400
1401
1402
1403
1404
1405
1406
1407
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_VwaitObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int done, foundEvent;
    const char *nameString;








|







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
1496
1497
1498
1499
1500
1501
1502
1503
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UpdateObjCmd(
    TCL_UNUSED(ClientData),
    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};







|







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
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(sizeof(ExecStack)
	    + (size-1) * 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;







|
|







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
1066
1067
1068
1069
1070
1071
1072
1073
    while (needed > newElems) {
	newElems *= 2;
    }
#else
    newElems = needed;
#endif

    newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *);

    oldPtr = esPtr;
    esPtr = (ExecStack *)Tcl_Alloc(newBytes);

    oldPtr->nextPtr = esPtr;
    esPtr->prevPtr = oldPtr;
    esPtr->nextPtr = NULL;







|







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
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_IS_DELETED)) {
	    Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr,
		    objResultPtr);
	}
	TRACE_WITH_OBJ(("=> "), objResultPtr);
	NEXT_INST_F(1, 0, 1);
    }
    break;







|







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
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
	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;
	}
	origCmd = TclGetOriginalCommand(cmd);
	if (origCmd == NULL) {
	    origCmd = cmd;
	}
	TclNewObj(objResultPtr);
	Tcl_GetCommandFullName(interp, origCmd, objResultPtr);
	TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS)));
	NEXT_INST_F(1, 1, 1);
    }

    /*
     * -----------------------------------------------------------------
     *	   Start of TclOO support instructions.







>
>
>
>
>
>
>
>
>
>
>
>









<
<
<
<
<
<







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
4650



4651

4652
4653
4654
4655
4656


4657
4658
4659
4660
4661
4662
4663
	TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));

	/*
	 * Extract the desired list element.
	 */

	if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK)
		&& !TclHasIntRep(value2Ptr, &tclListType)



		&& (TclGetIntForIndexM(NULL, value2Ptr, objc-1,

			&index) == TCL_OK)) {
	    TclDecrRefCount(value2Ptr);
	    tosPtr--;
	    pcAdjustment = 1;
	    goto lindexFastPath;


	}

	objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
	if (!objResultPtr) {
	    TRACE_ERROR(interp);
	    goto gotError;
	}







|
>
>
>
|
>
|
|
|
|
|
>
>







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
5132




5133
5134

5135
5136
5137

5138
5139
5140
5141
5142
5143
5144
	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,
		    &fromIdx) != TCL_OK




	    || TclGetIntForIndexM(interp, OBJ_AT_TOS, slength,
		    &toIdx) != TCL_OK) {

	    TRACE_ERROR(interp);
	    goto gotError;
	}


	if (fromIdx == TCL_INDEX_NONE) {
	    fromIdx = TCL_INDEX_START;
	}
	if (toIdx + 1 >= slength + 1) {
	    toIdx = 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
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", INDEX_TEMP_TABLE, &index) != TCL_OK) {
	    goto end;
	}
	if (Tcl_FSFileAttrsGet(interp, index, filePtr,
		&objPtr) != TCL_OK) {
	    goto end;
	}
	Tcl_SetObjResult(interp, objPtr);







|







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
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", 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);







|







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
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[1];		/* 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)








|







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
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.
		 */

		ClientData cd = (ClientData) Tcl_FSGetNativePath(norm);

		FsUpdateCwd(norm, TclNativeDupInternalRep(cd));
		Tcl_DecrRefCount(norm);
	    }
	    Tcl_DecrRefCount(retVal);
	} else {
	    /*







|







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
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 master filesystem. */
    fsRecPtr = FsGetFirstFilesystem();
    Claim();

    /*
     * Ensure that pathPtr is a valid pathname.
     */
    if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) {







|







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
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 | INDEX_TEMP_TABLE, indexPtr);

    Tcl_Free((void *)tablePtr);

    return result;
}

/*







|







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
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 & 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;
	}







|







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
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 & INDEX_TEMP_TABLE)) {
    irPtr = TclFetchIntRep(objPtr, &indexType);
    if (irPtr) {
	indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
    } else {
	Tcl_ObjIntRep ir;

	indexRep = (IndexRep*)Tcl_Alloc(sizeof(IndexRep));







|







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
955
956
957
958
959
960
961
962
    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[1];		/* 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;

/*







|







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
1293
1294
1295
1296
1297
1298
1299
1300
 */

#define CLL_END		(-1)

typedef struct ContLineLoc {
    int num;			/* Number of entries in loc, not counting the
				 * final -1 marker entry. */
    int loc[1];			/* Table of locations, as character offsets.
				 * 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;








|







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
1442
1443
1444
1445
1446
1447
1448
1449

typedef struct ExecStack {
    struct ExecStack *prevPtr;
    struct ExecStack *nextPtr;
    Tcl_Obj **markerPtr;
    Tcl_Obj **endPtr;
    Tcl_Obj **tosPtr;
    Tcl_Obj *stackWords[1];
} 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







|







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
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
				 * command. */
    Tcl_ObjCmdProc *nreProc;	/* NRE implementation of this command. */
} Command;

/*
 * Flag bits for commands.
 *
 * CMD_IS_DELETED -		Means that the command is in the process of
 *				being deleted (its deleteProc is currently
 *				executing). Other attempts to delete the
 *				command should be ignored.
 * CMD_TRACE_ACTIVE -		1 means that trace processing is currently
 *				underway for a rename/delete change. See the
 *				two flags below for which is currently being
 *				processed.
 * CMD_HAS_EXEC_TRACES -	1 means that this command has at least one
 *				execution trace (as opposed to simple
 *				delete/rename traces) in its tracePtr list.
 * CMD_COMPILES_EXPANDED -	1 means that this command has a compiler that
 *				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_IS_DELETED		    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








|



|



|


|









|







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
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
	Tcl_Obj *fileName, Tcl_Obj *attrObjPtr);

typedef struct TclFileAttrProcs {
    TclGetFileAttrProc *getProc;/* The procedure for getting attrs. */
    TclSetFileAttrProc *setProc;/* The procedure for setting attrs. */
} TclFileAttrProcs;

/*
 * Private flag value which controls Tcl_GetIndexFromObj*() routines
 * to instruct them not to cache lookups because the table will not
 * live long enough to make it worthwhile.  Must not clash with public
 * flag value TCL_EXACT.
 */

#define INDEX_TEMP_TABLE 2

/*
 * Opaque handle used in pipeline routines to encapsulate platform-dependent
 * state.
 */

typedef struct TclFile_ *TclFile;








<
<
<
<
<
<
<
<
<







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
4110
4111
4112
4113
4114
4115
4116
4117
/*
 * 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 TclSlaveObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclInvokeImportedCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOOPublicObjectCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOOPrivateObjectCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclOOMyClassObjCmd;

/*
 * TIP #462.







|







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
4913

4914
4915


4916

















4917
4918
4919
4920
4921
4922
4923

/*
 *----------------------------------------------------------------
 * 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) \

    if ((cmdPtr)->refCount-- <= 1) { \
	Tcl_Free(cmdPtr);\


    }


















/*
 *----------------------------------------------------------------
 * 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)







|
>
|
|
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







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
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 slave interpreter and
 * used by the source command to find the target command in the master when
 * the source command is invoked.
 */

typedef struct {
    Tcl_Obj *token;		/* Token for the alias command in the slave
				 * interp. This used to be the command name in
				 * the slave when the alias was first
				 * created. */
    Tcl_Interp *targetInterp;	/* Interp in which target command will be
				 * invoked. */
    Tcl_Command slaveCmd;	/* Source command in slave interpreter, bound
				 * to command that invokes the target command
				 * in the target interpreter. */
    Tcl_HashEntry *aliasEntryPtr;
				/* Entry for the alias hash table in slave.
				 * This is used by alias deletion to remove
				 * the alias from the slave interpreter alias
				 * table. */
    struct Target *targetPtr;	/* Entry for target command in master. This is
				 * used in the master interpreter to map back
				 * from the target command to aliases
				 * redirecting to it. */
    int objc;			/* Count of Tcl_Obj in the prefix of the
				 * target command to be invoked in the target
				 * interpreter. Additional arguments specified
				 * when calling the alias in the slave interp
				 * 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;

/*
 *
 * Slave:
 *
 * Used by the "interp" command to record and find information about slave
 * interpreters. Maps from a command name in the master to information about a
 * slave interpreter, e.g. what aliases are defined in it.
 */

typedef struct {
    Tcl_Interp *masterInterp;	/* Master interpreter for this slave. */
    Tcl_HashEntry *slaveEntryPtr;
				/* Hash entry in masters slave table for this
				 * slave interpreter. Used to find this
				 * record, and used when deleting the slave
				 * interpreter to delete it from the master's
				 * table. */
    Tcl_Interp	*slaveInterp;	/* The slave interpreter. */
    Tcl_Command interpCmd;	/* Interpreter object command. */
    Tcl_HashTable aliasTable;	/* Table which maps from names of commands in
				 * slave interpreter to struct Alias defined
				 * below. */
} Slave;

/*
 * struct Target:
 *
 * Maps from master interpreter commands back to the source commands in slave
 * interpreters. This is needed because aliases can be created between sibling
 * interpreters and must be deleted when the target interpreter is deleted. In
 * case they would not be deleted the source interpreter would be left with a
 * "dangling pointer". One such record is stored in the Master record of the
 * master interpreter with the master for each alias which directs to a
 * command in the master. These records are used to remove the source command
 * for an from a slave if/when the master is deleted. They are organized in a
 * doubly-linked list attached to the master interpreter.
 */

typedef struct Target {
    Tcl_Command	slaveCmd;	/* Command for alias in slave interp. */
    Tcl_Interp *slaveInterp;	/* Slave 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;

/*
 * Master:
 *
 * This record is used for two purposes: First, slaveTable (a hashtable) maps
 * from names of commands to slave interpreters. This hashtable is used to
 * store information about slave interpreters of this interpreter, to map over
 * all slaves, etc. The second purpose is to store information about all
 * aliases in slaves (or siblings) which direct to target commands in this
 * interpreter (using the targetsPtr doubly-linked list).
 *
 * NB: the flags field in the interp structure, used with SAFE_INTERP mask
 * denotes whether the interpreter is safe or not. Safe interpreters have
 * restricted functionality, can only create safe slave interpreters and can
 * only load safe extensions.
 */

typedef struct {
    Tcl_HashTable slaveTable;	/* Hash table for slave interpreters. Maps
				 * from command names to Slave records. */
    Target *targetsPtr;		/* The head of a doubly-linked list of all the
				 * target records which denote aliases from
				 * slaves or sibling interpreters that direct
				 * to commands in this interpreter. This list
				 * is used to remove dangling pointers from
				 * the slave (or sibling) interpreters when
				 * this interpreter is deleted. */
} Master;

/*
 * The following structure keeps track of all the Master and Slave information
 * on a per-interp basis.
 */

typedef struct {
    Master master;		/* Keeps track of all interps for which this
				 * interp is the Master. */
    Slave slave;		/* Information necessary for this interp to
				 * function as a slave. */
} 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.







|
|




|

|



|



|

|

|
|





|











|

|
|
|



|
|
|
|
|
|

|


|

|




|



|
|
|
|
|



|
|







|

|
|
|
|
|




|




|
|


|


|

|


|




|
|
|
|







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
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 *slaveInterp, Tcl_Interp *masterInterp,
			    Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc,
			    Tcl_Obj *const objv[]);
static int		AliasDelete(Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, Tcl_Obj *namePtr);
static int		AliasDescribe(Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, Tcl_Obj *objPtr);
static int		AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp);
static Tcl_ObjCmdProc		AliasNRCmd;
static Tcl_CmdDeleteProc	AliasObjCmdDeleteProc;
static Tcl_Interp *	GetInterp(Tcl_Interp *interp, Tcl_Obj *pathPtr);
static Tcl_Interp *	GetInterp2(Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static Tcl_InterpDeleteProc	InterpInfoDeleteProc;
static int		SlaveBgerror(Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, int objc,
			    Tcl_Obj *const objv[]);
static Tcl_Interp *	SlaveCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    int safe);
static int		SlaveDebugCmd(Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp,
			    int objc, Tcl_Obj *const objv[]);
static int		SlaveEval(Tcl_Interp *interp, Tcl_Interp *slaveInterp,
			    int objc, Tcl_Obj *const objv[]);
static int		SlaveExpose(Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, int objc,
			    Tcl_Obj *const objv[]);
static int		SlaveHide(Tcl_Interp *interp, Tcl_Interp *slaveInterp,
			    int objc, Tcl_Obj *const objv[]);
static int		SlaveHidden(Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp);
static int		SlaveInvokeHidden(Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp,
			    const char *namespaceName,
			    int objc, Tcl_Obj *const objv[]);
static int		SlaveMarkTrusted(Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp);
static Tcl_CmdDeleteProc	SlaveObjCmdDeleteProc;
static int		SlaveRecursionLimit(Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, int objc,
			    Tcl_Obj *const objv[]);
static int		SlaveCommandLimitCmd(Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, int consumedObjc,
			    int objc, Tcl_Obj *const objv[]);
static int		SlaveTimeLimitCmd(Tcl_Interp *interp,
			    Tcl_Interp *slaveInterp, int consumedObjc,
			    int objc, Tcl_Obj *const objv[]);
static void		InheritLimitsFromMaster(Tcl_Interp *slaveInterp,
			    Tcl_Interp *masterInterp);
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	NRSlaveCmd;


/*
 *----------------------------------------------------------------------
 *
 * TclSetPreInitScript --
 *







|



|

|
|






|
|

|

|
|

|

|
|

|

|
|
|
|


|
|
|
|
|

|
|

|
|

|
|












|







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
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 master, slave 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;
    Master *masterPtr;
    Slave *slavePtr;

    interpInfoPtr = (InterpInfo *)Tcl_Alloc(sizeof(InterpInfo));
    ((Interp *) interp)->interpInfo = interpInfoPtr;

    masterPtr = &interpInfoPtr->master;
    Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS);
    masterPtr->targetsPtr = NULL;

    slavePtr = &interpInfoPtr->slave;
    slavePtr->masterInterp	= NULL;
    slavePtr->slaveEntryPtr	= NULL;
    slavePtr->slaveInterp	= interp;
    slavePtr->interpCmd		= NULL;
    Tcl_InitHashTable(&slavePtr->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 master/slave/safe interpreter facilities.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Cleans up storage. Sets the interpInfoPtr field of the interp to NULL.
 *
 *---------------------------------------------------------------------------
 */

static void
InterpInfoDeleteProc(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp)		/* Interp being deleted. All commands for
				 * slave interps should already be deleted. */
{
    InterpInfo *interpInfoPtr;
    Slave *slavePtr;
    Master *masterPtr;
    Target *targetPtr;

    interpInfoPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;

    /*
     * There shouldn't be any commands left.
     */

    masterPtr = &interpInfoPtr->master;
    if (masterPtr->slaveTable.numEntries != 0) {
	Tcl_Panic("InterpInfoDeleteProc: still exist commands");
    }
    Tcl_DeleteHashTable(&masterPtr->slaveTable);

    /*
     * 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 = masterPtr->targetsPtr; targetPtr != NULL; ) {
	Target *tmpPtr = targetPtr->nextPtr;
	Tcl_DeleteCommandFromToken(targetPtr->slaveInterp,
		targetPtr->slaveCmd);
	targetPtr = tmpPtr;
    }

    slavePtr = &interpInfoPtr->slave;
    if (slavePtr->interpCmd != NULL) {
	/*
	 * Tcl_DeleteInterp() was called on this interpreter, rather "interp
	 * delete" or the equivalent deletion of the command in the master.
	 * First ensure that the cleanup callback doesn't try to delete the
	 * interp again.
	 */

	slavePtr->slaveInterp = NULL;
	Tcl_DeleteCommandFromToken(slavePtr->masterInterp,
		slavePtr->interpCmd);
    }

    /*
     * There shouldn't be any aliases left.
     */

    if (slavePtr->aliasTable.numEntries != 0) {
	Tcl_Panic("InterpInfoDeleteProc: still exist aliases");
    }
    Tcl_DeleteHashTable(&slavePtr->aliasTable);

    Tcl_Free(interpInfoPtr);
}

/*
 *----------------------------------------------------------------------
 *







|

















|
|




|
|
|

|
|
|
|
|
|














|












|

|


|
|








|
|


|







|

|
|



|
|


|




|
|
|






|


|







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
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
    Tcl_Obj *const objv[])		/* Argument objects. */
{
    return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv);
}

static int
NRInterpCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,			/* Current interpreter. */
    int objc,				/* Number of arguments. */
    Tcl_Obj *const objv[])		/* Argument objects. */
{
    Tcl_Interp *slaveInterp;
    int index;
    static const char *const options[] = {
	"alias",	"aliases",	"bgerror",	"cancel",
	"create",	"debug",	"delete",
	"eval",		"exists",	"expose",
	"hide",		"hidden",	"issafe",
	"invokehidden",	"limit",	"marktrusted",	"recursionlimit",



	"slaves",	"share",	"target",	"transfer",
	NULL
    };
    enum option {
	OPT_ALIAS,	OPT_ALIASES,	OPT_BGERROR,	OPT_CANCEL,
	OPT_CREATE,	OPT_DEBUG,	OPT_DELETE,
	OPT_EVAL,	OPT_EXISTS,	OPT_EXPOSE,
	OPT_HIDE,	OPT_HIDDEN,	OPT_ISSAFE,
	OPT_INVOKEHID,	OPT_LIMIT,	OPT_MARKTRUSTED,OPT_RECLIMIT,



	OPT_SLAVES,	OPT_SHARE,	OPT_TARGET,	OPT_TRANSFER
    };

    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 *masterInterp;

	if (objc < 4) {
	aliasArgs:
	    Tcl_WrongNumArgs(interp, 2, objv,
		    "slavePath slaveCmd ?masterPath masterCmd? ?arg ...?");
	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	if (objc == 4) {
	    return AliasDescribe(interp, slaveInterp, objv[3]);
	}
	if ((objc == 5) && (TclGetString(objv[4])[0] == '\0')) {
	    return AliasDelete(interp, slaveInterp, objv[3]);
	}
	if (objc > 5) {
	    masterInterp = GetInterp(interp, objv[4]);
	    if (masterInterp == NULL) {
		return TCL_ERROR;
	    }

	    return AliasCreate(interp, slaveInterp, masterInterp, objv[3],
		    objv[5], objc - 6, objv + 6);
	}
	goto aliasArgs;
    }
    case OPT_ALIASES:
	slaveInterp = GetInterp2(interp, objc, objv);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	return AliasList(interp, slaveInterp);
    case OPT_BGERROR:
	if (objc != 3 && objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?");
	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3);
    case OPT_CANCEL: {
	int i, flags;
	Tcl_Obj *resultObjPtr;
	static const char *const cancelOptions[] = {
	    "-unwind",	"--",	NULL
	};
	enum option {







|




|



|



>
>
>
|




|



>
>
>
|












|




|


|
|



|


|


|
|



|





|
|


|





|
|


|







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
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
	if (i < objc - 2) {
	    Tcl_WrongNumArgs(interp, 2, objv,
		    "?-unwind? ?--? ?path? ?result?");
	    return TCL_ERROR;
	}

	/*
	 * Did they specify a slave interp to cancel the script in progress
	 * in?  If not, use the current interp.
	 */

	if (i < objc) {
	    slaveInterp = GetInterp(interp, objv[i]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    }
	    i++;
	} else {
	    slaveInterp = interp;
	}

	if (i < objc) {
	    resultObjPtr = objv[i];

	    /*
	     * Tcl_CancelEval removes this reference.
	     */

	    Tcl_IncrRefCount(resultObjPtr);
	    i++;
	} else {
	    resultObjPtr = NULL;
	}

	return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags);
    }
    case OPT_CREATE: {
	int i, last, safe;
	Tcl_Obj *slavePtr;
	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.
	 */

	slavePtr = 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 (slavePtr != NULL) {
		Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
		return TCL_ERROR;
	    }
	    if (i < objc) {
		slavePtr = objv[i];
	    }
	}
	buf[0] = '\0';
	if (slavePtr == NULL) {
	    /*
	     * Create an anonymous interpreter -- we choose its name and the
	     * name of the command. We check that the command name that we use
	     * for the interpreter does not collide with an existing command
	     * in the master interpreter.
	     */

	    for (i = 0; ; i++) {
		Tcl_CmdInfo cmdInfo;

		sprintf(buf, "interp%d", i);
		if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) {
		    break;
		}
	    }
	    slavePtr = Tcl_NewStringObj(buf, -1);
	}
	if (SlaveCreate(interp, slavePtr, safe) == NULL) {
	    if (buf[0] != '\0') {
		Tcl_DecrRefCount(slavePtr);
	    }
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, slavePtr);
	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;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	return SlaveDebugCmd(interp, slaveInterp, objc - 3, objv + 3);
    case OPT_DELETE: {
	int i;
	InterpInfo *iiPtr;

	for (i = 2; i < objc; i++) {
	    slaveInterp = GetInterp(interp, objv[i]);
	    if (slaveInterp == NULL) {
		return TCL_ERROR;
	    } else if (slaveInterp == interp) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"cannot delete the current interpreter", -1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
			"DELETESELF", NULL);
		return TCL_ERROR;
	    }
	    iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
	    Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp,
		    iiPtr->slave.interpCmd);
	}
	return TCL_OK;
    }
    case OPT_EVAL:
	if (objc < 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	return SlaveEval(interp, slaveInterp, objc - 3, objv + 3);
    case OPT_EXISTS: {
	int exists = 1;

	slaveInterp = GetInterp2(interp, objc, objv);
	if (slaveInterp == 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;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3);
    case OPT_HIDE:
	if ((objc < 4) || (objc > 5)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?");
	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	return SlaveHide(interp, slaveInterp, objc - 3, objv + 3);
    case OPT_HIDDEN:
	slaveInterp = GetInterp2(interp, objc, objv);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	return SlaveHidden(interp, slaveInterp);
    case OPT_ISSAFE:
	slaveInterp = GetInterp2(interp, objc, objv);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp)));
	return TCL_OK;
    case OPT_INVOKEHID: {
	int i;
	const char *namespaceName;
	static const char *const hiddenOptions[] = {
	    "-global",	"-namespace",	"--", NULL
	};







|




|
|




|















|



|














|














|




|



|




|










|

|

|



|











|
|


|





|
|

|






|
|
|








|
|


|



|
|














|
|


|





|
|


|

|
|


|

|
|


|







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
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
	    }
	}
	if (objc - i < 1) {
	    Tcl_WrongNumArgs(interp, 2, objv,
		    "path ?-namespace ns? ?-global? ?--? cmd ?arg ..?");
	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	return SlaveInvokeHidden(interp, slaveInterp, 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;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == 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 SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv);
	case LIMIT_TYPE_TIME:
	    return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv);
	}
    }
    break;
    case OPT_MARKTRUSTED:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "path");
	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	return SlaveMarkTrusted(interp, slaveInterp);
    case OPT_RECLIMIT:
	if (objc != 3 && objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?");
	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3);

    case OPT_SLAVES: {


	InterpInfo *iiPtr;
	Tcl_Obj *resultPtr;
	Tcl_HashEntry *hPtr;
	Tcl_HashSearch hashSearch;
	char *string;

	slaveInterp = GetInterp2(interp, objc, objv);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
	resultPtr = Tcl_NewObj();
	hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch);
	for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
	    string = (char *)Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr);
	    Tcl_ListObjAppendElement(NULL, resultPtr,
		    Tcl_NewStringObj(string, -1));
	}
	Tcl_SetObjResult(interp, resultPtr);
	return TCL_OK;
    }
    case OPT_TRANSFER:
    case OPT_SHARE: {
	Tcl_Interp *masterInterp;	/* The master of the slave. */
	Tcl_Channel chan;

	if (objc != 5) {
	    Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");
	    return TCL_ERROR;
	}
	masterInterp = GetInterp(interp, objv[2]);
	if (masterInterp == NULL) {
	    return TCL_ERROR;
	}
	chan = Tcl_GetChannel(masterInterp, TclGetString(objv[3]), NULL);
	if (chan == NULL) {
	    Tcl_TransferResult(masterInterp, TCL_OK, interp);
	    return TCL_ERROR;
	}
	slaveInterp = GetInterp(interp, objv[4]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}
	Tcl_RegisterChannel(slaveInterp, chan);
	if (index == OPT_TRANSFER) {
	    /*
	     * When transferring, as opposed to sharing, we must unhitch the
	     * channel from the interpreter where it started.
	     */

	    if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) {
		Tcl_TransferResult(masterInterp, TCL_OK, interp);
		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;
	}

	slaveInterp = GetInterp(interp, objv[2]);
	if (slaveInterp == NULL) {
	    return TCL_ERROR;
	}

	aliasName = TclGetString(objv[3]);

	iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
	hPtr = Tcl_FindHashEntry(&iiPtr->slave.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;







|
|


|
















|
|








|

|








|
|


|





|
|


|
>
|
>
>






|
|


|

|

|








|






|
|


|

|


|
|


|






|
|
















|
|





|
|







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
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
 *
 *	Creates an alias between two interpreters.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Creates a new alias, manipulates the result field of slaveInterp.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_CreateAlias(
    Tcl_Interp *slaveInterp,	/* Interpreter for source command. */
    const char *slaveCmd,	/* Command to install in slave. */
    Tcl_Interp *targetInterp,	/* Interpreter for target command. */
    const char *targetCmd,	/* Name of target command. */
    int argc,			/* How many additional arguments? */
    const char *const *argv)	/* These are the additional args. */
{
    Tcl_Obj *slaveObjPtr, *targetObjPtr;
    Tcl_Obj **objv;
    int i;
    int result;

    objv = (Tcl_Obj **)TclStackAlloc(slaveInterp, sizeof(Tcl_Obj *) * argc);
    for (i = 0; i < argc; i++) {
	objv[i] = Tcl_NewStringObj(argv[i], -1);
	Tcl_IncrRefCount(objv[i]);
    }

    slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
    Tcl_IncrRefCount(slaveObjPtr);

    targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
    Tcl_IncrRefCount(targetObjPtr);

    result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,
	    targetObjPtr, argc, objv);

    for (i = 0; i < argc; i++) {
	Tcl_DecrRefCount(objv[i]);
    }
    TclStackFree(slaveInterp, objv);
    Tcl_DecrRefCount(targetObjPtr);
    Tcl_DecrRefCount(slaveObjPtr);

    return result;
}

/*
 *----------------------------------------------------------------------
 *







|






|
|





|




|





|
|




|





|

|







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
1232
1233
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
 *	Creates a new alias.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_CreateAliasObj(
    Tcl_Interp *slaveInterp,	/* Interpreter for source command. */
    const char *slaveCmd,	/* Command to install in slave. */
    Tcl_Interp *targetInterp,	/* Interpreter for target command. */
    const char *targetCmd,	/* Name of target command. */
    int objc,			/* How many additional arguments? */
    Tcl_Obj *const objv[])	/* Argument vector. */
{
    Tcl_Obj *slaveObjPtr, *targetObjPtr;
    int result;

    slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
    Tcl_IncrRefCount(slaveObjPtr);

    targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
    Tcl_IncrRefCount(targetObjPtr);

    result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,
	    targetObjPtr, objc, objv);

    Tcl_DecrRefCount(slaveObjPtr);
    Tcl_DecrRefCount(targetObjPtr);
    return result;
}

/*
 *----------------------------------------------------------------------
 *







|
|





|


|
|




|


|







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
1288
1289
1290
1291
1292
1293
1294
1295
{
    InterpInfo *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
    Tcl_HashEntry *hPtr;
    Alias *aliasPtr;
    int i, objc;
    Tcl_Obj **objv;

    hPtr = Tcl_FindHashEntry(&iiPtr->slave.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);







|







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
1350
1351
1352
1353
1354
1355
1356
1357
{
    InterpInfo *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
    Tcl_HashEntry *hPtr;
    Alias *aliasPtr;
    int objc;
    Tcl_Obj **objv;

    hPtr = Tcl_FindHashEntry(&iiPtr->slave.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);







|







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
1438
1439
1440
1441
1442
1443
1444
1445
	/*
	 * 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 slave 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;







|







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
1491
1492
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
 *	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
 *	slave interpreter.
 *
 *----------------------------------------------------------------------
 */

static int
AliasCreate(
    Tcl_Interp *interp,		/* Interp for error reporting. */
    Tcl_Interp *slaveInterp,	/* Interp where alias cmd will live or from
				 * which alias will be deleted. */
    Tcl_Interp *masterInterp,	/* 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;
    Slave *slavePtr;
    Master *masterPtr;
    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 = masterInterp;

    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(slaveInterp);
    Tcl_Preserve(masterInterp);

    if (slaveInterp == masterInterp) {
	aliasPtr->slaveCmd = Tcl_NRCreateCommand(slaveInterp,
		TclGetString(namePtr), TclLocalAliasObjCmd, AliasNRCmd,
		aliasPtr, AliasObjCmdDeleteProc);
    } else {
	aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
		TclGetString(namePtr), TclAliasObjCmd, aliasPtr,
		AliasObjCmdDeleteProc);
    }

    if (TclPreventAliasLoop(interp, slaveInterp,
	    aliasPtr->slaveCmd) != 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->slaveCmd;
	cmdPtr->clientData = NULL;
	cmdPtr->deleteProc = NULL;
	cmdPtr->deleteData = NULL;
	Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);

	Tcl_Free(aliasPtr);

	/*
	 * The result was already set by TclPreventAliasLoop.
	 */

	Tcl_Release(slaveInterp);
	Tcl_Release(masterInterp);
	return TCL_ERROR;
    }

    /*
     * Make an entry in the alias table. If it already exists, retry.
     */

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    while (1) {
	Tcl_Obj *newToken;
	const char *string;

	string = TclGetString(aliasPtr->token);
	hPtr = Tcl_CreateHashEntry(&slavePtr->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







|







|

|









|
|






|











|
|

|
|



|




|
|















|



|







|
|







|





|







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
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
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
     *
     * 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->slaveCmd = aliasPtr->slaveCmd;
    targetPtr->slaveInterp = slaveInterp;

    masterPtr = &((InterpInfo*) ((Interp*) masterInterp)->interpInfo)->master;
    targetPtr->nextPtr = masterPtr->targetsPtr;
    targetPtr->prevPtr = NULL;
    if (masterPtr->targetsPtr != NULL) {
	masterPtr->targetsPtr->prevPtr = targetPtr;
    }
    masterPtr->targetsPtr = targetPtr;
    aliasPtr->targetPtr = targetPtr;

    Tcl_SetObjResult(interp, aliasPtr->token);

    Tcl_Release(slaveInterp);
    Tcl_Release(masterInterp);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AliasDelete --
 *
 *	Deletes the given alias from the slave interpreter given.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Deletes the alias from the slave interpreter.
 *
 *----------------------------------------------------------------------
 */

static int
AliasDelete(
    Tcl_Interp *interp,		/* Interpreter for result & errors. */
    Tcl_Interp *slaveInterp,	/* Interpreter containing alias. */
    Tcl_Obj *namePtr)		/* Name of alias to delete. */
{
    Slave *slavePtr;
    Alias *aliasPtr;
    Tcl_HashEntry *hPtr;

    /*
     * If the alias has been renamed in the slave, the master can still use
     * the original name (with which it was created) to find the alias to
     * delete it.
     */

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr));
    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(slaveInterp, aliasPtr->slaveCmd);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AliasDescribe --







|
|

|
|

|
|

|




|
|








|





|







|


|




|




|
|








|







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
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
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
 *
 *----------------------------------------------------------------------
 */

static int
AliasDescribe(
    Tcl_Interp *interp,		/* Interpreter for result & errors. */
    Tcl_Interp *slaveInterp,	/* Interpreter containing alias. */
    Tcl_Obj *namePtr)		/* Name of alias to describe. */
{
    Slave *slavePtr;
    Tcl_HashEntry *hPtr;
    Alias *aliasPtr;
    Tcl_Obj *prefixPtr;

    /*
     * If the alias has been renamed in the slave, the master can still use
     * the original name (with which it was created) to find the alias to
     * describe it.
     */

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, 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 slave interpreter.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
AliasList(
    Tcl_Interp *interp,		/* Interp for data return. */
    Tcl_Interp *slaveInterp)	/* Interp whose aliases to compute. */
{
    Tcl_HashEntry *entryPtr;
    Tcl_HashSearch hashSearch;
    Tcl_Obj *resultPtr = Tcl_NewObj();
    Alias *aliasPtr;
    Slave *slavePtr;

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;

    entryPtr = Tcl_FirstHashEntry(&slavePtr->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 slave
 *	interpreter. One such command exists for each alias. When invoked,
 *	this function redirects the invocation to the target command in the
 *	master interpreter as designated by the Alias record associated with
 *	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.
 *







|


|





|




|
|














|













|





|

|

|













|


|







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
2012
2013
2014
2015
2016
2017
2018
2019
}

/*
 *----------------------------------------------------------------------
 *
 * AliasObjCmdDeleteProc --
 *
 *	Is invoked when an alias command is deleted in a slave. 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







|







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
2042
2043
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
    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 master list.
     */

    targetPtr = aliasPtr->targetPtr;
    if (targetPtr->prevPtr != NULL) {
	targetPtr->prevPtr->nextPtr = targetPtr->nextPtr;
    } else {
	Master *masterPtr = &((InterpInfo *) ((Interp *)
		aliasPtr->targetInterp)->interpInfo)->master;

	masterPtr->targetsPtr = targetPtr->nextPtr;
    }
    if (targetPtr->nextPtr != NULL) {
	targetPtr->nextPtr->prevPtr = targetPtr->prevPtr;
    }

    Tcl_Free(targetPtr);
    Tcl_Free(aliasPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateSlave --
 *
 *	Creates a slave interpreter. The slavePath argument denotes the name
 *	of the new slave relative to the current interpreter; the slave is a
 *	direct descendant of the one-before-last component of the path,
 *	e.g. it is a descendant of the current interpreter if the slavePath
 *	argument contains only one component. Optionally makes the slave
 *	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 slavePath argument.
 *
 *----------------------------------------------------------------------
 */

Tcl_Interp *
Tcl_CreateSlave(
    Tcl_Interp *interp,		/* Interpreter to start search at. */
    const char *slavePath,	/* Name of slave to create. */
    int isSafe)			/* Should new slave be "safe" ? */
{
    Tcl_Obj *pathPtr;
    Tcl_Interp *slaveInterp;

    pathPtr = Tcl_NewStringObj(slavePath, -1);
    slaveInterp = SlaveCreate(interp, pathPtr, isSafe);
    Tcl_DecrRefCount(pathPtr);

    return slaveInterp;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetSlave --
 *
 *	Finds a slave 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_GetSlave(
    Tcl_Interp *interp,		/* Interpreter to start search from. */
    const char *slavePath)	/* Path of slave to find. */
{
    Tcl_Obj *pathPtr;
    Tcl_Interp *slaveInterp;

    pathPtr = Tcl_NewStringObj(slavePath, -1);
    slaveInterp = GetInterp(interp, pathPtr);
    Tcl_DecrRefCount(pathPtr);

    return slaveInterp;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetMaster --
 *
 *	Finds the master interpreter of a slave interpreter.
 *
 * Results:
 *	Returns a Tcl_Interp * for the master interpreter or NULL if none.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Interp *
Tcl_GetMaster(
    Tcl_Interp *interp)		/* Get the master of this interpreter. */
{
    Slave *slavePtr;		/* Slave record of this interpreter. */

    if (interp == NULL) {
	return NULL;
    }
    slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave;
    return slavePtr->masterInterp;
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetChildCancelFlags --
 *
 *	This function marks all slave interpreters belonging to a given
 *	interpreter as being canceled or not canceled, depending on the
 *	provided flags.
 *
 * Results:
 *	None.
 *
 * Side effects:







|






|
|

|












|

|
|

|
|








|





|

|
|


|

|
|


|





|

|











|

|


|

|
|


|





|

|


|








|
|

|




|
|







|







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
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
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
    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. */
{
    Master *masterPtr;		/* Master record of given interpreter. */
    Tcl_HashEntry *hPtr;	/* Search element. */
    Tcl_HashSearch hashSearch;	/* Search variable. */
    Slave *slavePtr;		/* Slave record of interpreter. */
    Interp *iPtr;

    if (interp == NULL) {
	return;
    }

    flags &= (CANCELED | TCL_CANCEL_UNWIND);

    masterPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->master;

    hPtr = Tcl_FirstHashEntry(&masterPtr->slaveTable, &hashSearch);
    for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
	slavePtr = (Slave *)Tcl_GetHashValue(hPtr);
	iPtr = (Interp *) slavePtr->slaveInterp;

	if (iPtr == NULL) {
	    continue;
	}

	if (flags == 0) {
	    TclResetCancellation((Tcl_Interp *) iPtr, force);
	} else {
	    TclSetCancelFlags(iPtr, flags);
	}

	/*
	 * Now, recursively handle this for the slaves of this slave
	 * 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 slaves (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







|


|








|

|

|
|












|















|







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
2266
2267
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
	Tcl_SetObjResult(interp, Tcl_NewObj());
	return TCL_OK;
    }
    if (targetInterp == NULL) {
	return TCL_ERROR;
    }
    iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
    if (Tcl_GetInterpPath(interp, iiPtr->slave.masterInterp) != TCL_OK){
	return TCL_ERROR;
    }
    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
	    Tcl_NewStringObj((const char *)Tcl_GetHashKey(&iiPtr->master.slaveTable,
		    iiPtr->slave.slaveEntryPtr), -1));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetInterp --
 *
 *	Helper function to find a slave interpreter given a pathname.
 *
 * Results:
 *	Returns the slave 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. */
    Slave *slavePtr;		/* Interim slave record. */
    Tcl_Obj **objv;
    int objc, i;
    Tcl_Interp *searchInterp;	/* Interim storage for interp. to find. */
    InterpInfo *masterInfoPtr;

    if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
	return NULL;
    }

    searchInterp = interp;
    for (i = 0; i < objc; i++) {
	masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo;
	hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable,
		TclGetString(objv[i]));
	if (hPtr == NULL) {
	    searchInterp = NULL;
	    break;
	}
	slavePtr = (Slave *)Tcl_GetHashValue(hPtr);
	searchInterp = slavePtr->slaveInterp;
	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;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveBgerror --
 *
 *	Helper function to set/query the background error handling command
 *	prefix of an interp
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	When (objc == 1), slaveInterp will be set to a new background handler
 *	of objv[0].
 *
 *----------------------------------------------------------------------
 */

static int
SlaveBgerror(
    Tcl_Interp *interp,		/* Interp for error return. */
    Tcl_Interp *slaveInterp,	/* 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(slaveInterp, objv[0]);
    }
    Tcl_SetObjResult(interp, TclGetBgErrorHandler(slaveInterp));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveCreate --
 *
 *	Helper function to do the actual work of creating a slave interp and
 *	new object command. Also optionally makes the new slave 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 slave interpreter and a new object command.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Interp *
SlaveCreate(
    Tcl_Interp *interp,		/* Interp. to start search from. */
    Tcl_Obj *pathPtr,		/* Path (name) of slave to create. */
    int safe)			/* Should we make it "safe"? */
{
    Tcl_Interp *masterInterp, *slaveInterp;
    Slave *slavePtr;
    InterpInfo *masterInfoPtr;
    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) {
	masterInterp = interp;
	path = TclGetString(pathPtr);
    } else {
	Tcl_Obj *objPtr;

	objPtr = Tcl_NewListObj(objc - 1, objv);
	masterInterp = GetInterp(interp, objPtr);
	Tcl_DecrRefCount(objPtr);
	if (masterInterp == NULL) {
	    return NULL;
	}
	path = TclGetString(objv[objc - 1]);
    }
    if (safe == 0) {
	safe = Tcl_IsSafe(masterInterp);
    }

    masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo;
    hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path,
	    &isNew);
    if (isNew == 0) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"interpreter named \"%s\" already exists, cannot create",
		path));
	return NULL;
    }

    slaveInterp = Tcl_CreateInterp();
    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    slavePtr->masterInterp = masterInterp;
    slavePtr->slaveEntryPtr = hPtr;
    slavePtr->slaveInterp = slaveInterp;
    slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path,
	    TclSlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc);
    Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
    Tcl_SetHashValue(hPtr, slavePtr);
    Tcl_SetVar2(slaveInterp, "tcl_interactive", NULL, "0", TCL_GLOBAL_ONLY);

    /*
     * Inherit the recursion limit.
     */

    ((Interp *) slaveInterp)->maxNestingDepth =
	    ((Interp *) masterInterp)->maxNestingDepth;

    if (safe) {
	if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) {
	    goto error;
	}
    } else {
	if (Tcl_Init(slaveInterp) == TCL_ERROR) {
	    goto error;
	}

	/*
	 * This will create the "memory" command in slave interpreters if we
	 * compiled with TCL_MEM_DEBUG, otherwise it does nothing.
	 */

	Tcl_InitMemory(slaveInterp);
    }

    /*
     * Inherit the TIP#143 limits.
     */

    InheritLimitsFromMaster(slaveInterp, masterInterp);

    /*
     * The [clock] command presents a safe API, but uses unsafe features in
     * its implementation. This means it has to be implemented in safe interps
     * as an alias to a version in the (trusted) master.
     */

    if (safe) {
	Tcl_Obj *clockObj;
	int status;

	TclNewLiteralStringObj(clockObj, "clock");
	Tcl_IncrRefCount(clockObj);
	status = AliasCreate(interp, slaveInterp, masterInterp, clockObj,
		clockObj, 0, NULL);
	Tcl_DecrRefCount(clockObj);
	if (status != TCL_OK) {
	    goto error2;
	}
    }

    return slaveInterp;

  error:
    Tcl_TransferResult(slaveInterp, TCL_ERROR, interp);
  error2:
    Tcl_DeleteInterp(slaveInterp);

    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclSlaveObjCmd --
 *
 *	Command to manipulate an interpreter, e.g. to send commands to it to
 *	be evaluated. One such command exists for each slave interpreter.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See user documentation for details.
 *
 *----------------------------------------------------------------------
 */

int
TclSlaveObjCmd(
    ClientData clientData,	/* Slave interpreter. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv);
}

static int
NRSlaveCmd(
    ClientData clientData,	/* Slave interpreter. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Interp *slaveInterp = (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 (slaveInterp == NULL) {
	Tcl_Panic("TclSlaveObjCmd: 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, slaveInterp, objv[2]);
	    }
	    if (TclGetString(objv[3])[0] == '\0') {
		if (objc == 4) {
		    return AliasDelete(interp, slaveInterp, objv[2]);
		}
	    } else {
		return AliasCreate(interp, slaveInterp, 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, slaveInterp);
    case OPT_BGERROR:
	if (objc != 2 && objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?");
	    return TCL_ERROR;
	}
	return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2);
    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 SlaveDebugCmd(interp, slaveInterp, objc - 2, objv + 2);
    case OPT_EVAL:
	if (objc < 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
	    return TCL_ERROR;
	}
	return SlaveEval(interp, slaveInterp, objc - 2, objv + 2);
    case OPT_EXPOSE:
	if ((objc < 3) || (objc > 4)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?");
	    return TCL_ERROR;
	}
	return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2);
    case OPT_HIDE:
	if ((objc < 3) || (objc > 4)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?");
	    return TCL_ERROR;
	}
	return SlaveHide(interp, slaveInterp, objc - 2, objv + 2);
    case OPT_HIDDEN:
	if (objc != 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
	}
	return SlaveHidden(interp, slaveInterp);
    case OPT_ISSAFE:
	if (objc != 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
	}
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp)));
	return TCL_OK;
    case OPT_INVOKEHIDDEN: {
	int i;
	const char *namespaceName;
	static const char *const hiddenOptions[] = {
	    "-global",	"-namespace",	"--", NULL
	};







|



|
|








|


|















|



|







|
|





|
|
















|








|






|

|














|

|






|

|
|







|





|

|


|
|
|









|





|

|





|


|
|








|
|
|
|
|
|
|
|
|
|





|
|


|



|




|



|






|




|








|







|


|

|







|


|











|
|




|



|
|




|














|
|















|



|


|










|





|









|





|





|





|





|





|







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
2679
2680
2681
2682
2683
2684
2685
2686
	    }
	}
	if (objc - i < 1) {
	    Tcl_WrongNumArgs(interp, 2, objv,
		    "?-namespace ns? ?-global? ?--? cmd ?arg ..?");
	    return TCL_ERROR;
	}
	return SlaveInvokeHidden(interp, slaveInterp, namespaceName,
		objc - i, objv + i);
    }
    case OPT_LIMIT: {
	static const char *const limitTypes[] = {
	    "commands", "time", NULL
	};
	enum LimitTypes {







|







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
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
	}
	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 SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv);
	case LIMIT_TYPE_TIME:
	    return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv);
	}
    }
    break;
    case OPT_MARKTRUSTED:
	if (objc != 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
	}
	return SlaveMarkTrusted(interp, slaveInterp);
    case OPT_RECLIMIT:
	if (objc != 2 && objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?");
	    return TCL_ERROR;
	}
	return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2);
    }

    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveObjCmdDeleteProc --
 *
 *	Invoked when an object command for a slave interpreter is deleted;
 *	cleans up all state associated with the slave interpreter and destroys
 *	the slave interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Cleans up all state associated with the slave interpreter and destroys
 *	the slave interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
SlaveObjCmdDeleteProc(
    ClientData clientData)	/* The SlaveRecord for the command. */
{
    Slave *slavePtr;		/* Interim storage for Slave record. */
    Tcl_Interp *slaveInterp = (Tcl_Interp *)clientData;
				/* And for a slave interp. */

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;

    /*
     * Unlink the slave from its master interpreter.
     */

    Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr);

    /*
     * Set to NULL so that when the InterpInfo is cleaned up in the slave it
     * does not try to delete the command causing all sorts of grief. See
     * SlaveRecordDeleteProc().
     */

    slavePtr->interpCmd = NULL;

    if (slavePtr->slaveInterp != NULL) {
	Tcl_DeleteInterp(slavePtr->slaveInterp);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveDebugCmd -- TIP #378
 *
 *	Helper function to handle 'debug' command in a slave interpreter.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May modify INTERP_DEBUG_FRAME flag in the slave.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveDebugCmd(
    Tcl_Interp *interp,		/* Interp for error return. */
    Tcl_Interp *slaveInterp,	/* The slave 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 *) slaveInterp;
    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);







|

|








|





|








|

|
|
|





|
|





|
|

|
|
|

|


|


|


|

|


|

|
|






|

|





|





|

|














|







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
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
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
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveEval --
 *
 *	Helper function to evaluate a command in a slave interpreter.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Whatever the command does.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveEval(
    Tcl_Interp *interp,		/* Interp for error return. */
    Tcl_Interp *slaveInterp,	/* The slave 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 slave
     * interpreter now; otherwise, canceling a script in a master interpreter
     * can result in a situation where a slave interpreter can no longer
     * evaluate any scripts unless somebody calls the TclResetCancellation
     * function for that particular Tcl_Interp.
     */

    TclSetChildCancelFlags(slaveInterp, 0, 0);

    Tcl_Preserve(slaveInterp);
    Tcl_AllowExceptions(slaveInterp);

    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(slaveInterp, objv[0], 0, invoker, word);
    } else {
	Tcl_Obj *objPtr = Tcl_ConcatObj(objc, objv);
	Tcl_IncrRefCount(objPtr);
	result = Tcl_EvalObjEx(slaveInterp, objPtr, 0);
	Tcl_DecrRefCount(objPtr);
    }
    Tcl_TransferResult(slaveInterp, result, interp);

    Tcl_Release(slaveInterp);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveExpose --
 *
 *	Helper function to expose a command in a slave interpreter.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	After this call scripts in the slave will be able to invoke the newly
 *	exposed command.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveExpose(
    Tcl_Interp *interp,		/* Interp for error return. */
    Tcl_Interp *slaveInterp,	/* 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(slaveInterp, TclGetString(objv[0]),
	    name) != TCL_OK) {
	Tcl_TransferResult(slaveInterp, TCL_ERROR, interp);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveRecursionLimit --
 *
 *	Helper function to set/query the Recursion limit of an interp
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	When (objc == 1), slaveInterp will be set to a new recursion limit of
 *	objv[0].
 *
 *----------------------------------------------------------------------
 */

static int
SlaveRecursionLimit(
    Tcl_Interp *interp,		/* Interp for error return. */
    Tcl_Interp *slaveInterp,	/* Interp in which limit is set/queried. */
    int objc,			/* Set or Query. */
    Tcl_Obj *const objv[])	/* Argument strings. */
{
    Interp *iPtr;
    int limit;

    if (objc) {







|

|











|

|







|
|
|




|

|
|












|



|


|

|






|

|





|






|

|















|

|








|







|






|

|







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
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
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
	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(slaveInterp, limit);
	iPtr = (Interp *) slaveInterp;
	if (interp == slaveInterp && 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(slaveInterp, 0);
	Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limit));
	return TCL_OK;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveHide --
 *
 *	Helper function to hide a command in a slave interpreter.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	After this call scripts in the slave will no longer be able to invoke
 *	the named command.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveHide(
    Tcl_Interp *interp,		/* Interp for error return. */
    Tcl_Interp *slaveInterp,	/* 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(slaveInterp, TclGetString(objv[0]), name) != TCL_OK) {
	Tcl_TransferResult(slaveInterp, TCL_ERROR, interp);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveHidden --
 *
 *	Helper function to compute list of hidden commands in a slave
 *	interpreter.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveHidden(
    Tcl_Interp *interp,		/* Interp for data return. */
    Tcl_Interp *slaveInterp)	/* 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 *) slaveInterp)->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;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveInvokeHidden --
 *
 *	Helper function to invoke a hidden command in a slave interpreter.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Whatever the hidden command does.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveInvokeHidden(
    Tcl_Interp *interp,		/* Interp for error return. */
    Tcl_Interp *slaveInterp,	/* The slave 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(slaveInterp);
    Tcl_AllowExceptions(slaveInterp);

    if (namespaceName == NULL) {
	NRE_callback *rootPtr = TOP_CB(slaveInterp);

	Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp,
		rootPtr, NULL, NULL);
	return TclNRInvoke(NULL, slaveInterp, objc, objv);
    } else {
	Namespace *nsPtr, *dummy1, *dummy2;
	const char *tail;

	result = TclGetNamespaceForQualName(slaveInterp, namespaceName, NULL,
		TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG
		| TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
	if (result == TCL_OK) {
	    result = TclObjInvokeNamespace(slaveInterp, objc, objv,
		    (Tcl_Namespace *) nsPtr, TCL_INVOKE_HIDDEN);
	}
    }

    Tcl_TransferResult(slaveInterp, result, interp);

    Tcl_Release(slaveInterp);
    return result;
}

static int
NRPostInvokeHidden(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0];
    NRE_callback *rootPtr = (NRE_callback *)data[1];

    if (interp != slaveInterp) {
	result = TclNRRunCallbacks(slaveInterp, result, rootPtr);
	Tcl_TransferResult(slaveInterp, result, interp);
    }
    Tcl_Release(slaveInterp);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveMarkTrusted --
 *
 *	Helper function to mark a slave interpreter as trusted (unsafe).
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	After this call the hard-wired security checks in the core no longer
 *	prevent the slave from performing certain operations.
 *
 *----------------------------------------------------------------------
 */

static int
SlaveMarkTrusted(
    Tcl_Interp *interp,		/* Interp for error return. */
    Tcl_Interp *slaveInterp)	/* The slave 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 *) slaveInterp)->flags &= ~SAFE_INTERP;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_IsSafe --







|
|
|








|








|

|





|






|

|















|
|








|

|












|

|






|















|

|











|

|
















|
|


|

|

|




|



|




|

|









|


|
|
|

|






|

|






|





|

|










|







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
3264
3265
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

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 *master = ((InterpInfo*) iPtr->interpInfo)->slave.masterInterp;

    TclHideUnsafeCommands(interp);

    if (master != NULL) {
	/*
	 * Alias these function implementations in the slave to those in the
	 * master; 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 slave.
     */

    Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY);

    /*
     * Remove unsafe parts of tcl_platform
     */







|



|

|
|
















|







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
4189
4190
4191
4192
4193
4194
4195
4196

/*
 *----------------------------------------------------------------------
 *
 * DeleteScriptLimitCallback --
 *
 *	Callback for when a script limit (a limit callback implemented as a
 *	Tcl script in a master interpreter, as set up from Tcl) is deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The reference to the script callback from the controlling interpreter
 *	is removed.







|







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
4402
4403
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
    Tcl_InitHashTable(&iPtr->limit.callbacks,
	    sizeof(ScriptLimitCallbackKey)/sizeof(int));
}

/*
 *----------------------------------------------------------------------
 *
 * InheritLimitsFromMaster --
 *
 *	Derive the interpreter limit configuration for a slave interpreter
 *	from the limit config for the master.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The slave interpreter limits are set so that if the master has a
 *	limit, it may not exceed it by handing off work to slave interpreters.
 *	Note that this does not transfer limit callbacks from the master to
 *	the slave.
 *
 *----------------------------------------------------------------------
 */

static void
InheritLimitsFromMaster(
    Tcl_Interp *slaveInterp,
    Tcl_Interp *masterInterp)
{
    Interp *slavePtr = (Interp *) slaveInterp;
    Interp *masterPtr = (Interp *) masterInterp;

    if (masterPtr->limit.active & TCL_LIMIT_COMMANDS) {
	slavePtr->limit.active |= TCL_LIMIT_COMMANDS;
	slavePtr->limit.cmdCount = 0;
	slavePtr->limit.cmdGranularity = masterPtr->limit.cmdGranularity;
    }
    if (masterPtr->limit.active & TCL_LIMIT_TIME) {
	slavePtr->limit.active |= TCL_LIMIT_TIME;
	memcpy(&slavePtr->limit.time, &masterPtr->limit.time,
		sizeof(Tcl_Time));
	slavePtr->limit.timeGranularity = masterPtr->limit.timeGranularity;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveCommandLimitCmd --
 *
 *	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
SlaveCommandLimitCmd(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Interp *slaveInterp,	/* 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
    };







|

|
|





|
|
|
|





|
|
|

|
|

|
|
|
|

|
|
|

|






|















|

|







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
4485
4486
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
    /*
     * 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 == slaveInterp) {
	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 = slaveInterp;
	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(slaveInterp,
		TCL_LIMIT_COMMANDS)));

	if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) {
	    Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1),
		    Tcl_NewWideIntObj(Tcl_LimitGetCommands(slaveInterp)));
	} 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 = slaveInterp;
	    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(slaveInterp, TCL_LIMIT_COMMANDS)));
	    break;
	case OPT_VAL:
	    if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) {
		Tcl_SetObjResult(interp,
			Tcl_NewWideIntObj(Tcl_LimitGetCommands(slaveInterp)));
	    }
	    break;
	}
	return TCL_OK;
    } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
	Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
	return TCL_ERROR;







|










|



















|


|

|
















|











|


|

|







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
4612
4613
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
			    "BADVALUE", NULL);
		    return TCL_ERROR;
		}
		break;
	    }
	}
	if (scriptObj != NULL) {
	    SetScriptLimitCallback(interp, TCL_LIMIT_COMMANDS, slaveInterp,
		    (scriptLen > 0 ? scriptObj : NULL));
	}
	if (granObj != NULL) {
	    Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_COMMANDS, gran);
	}
	if (limitObj != NULL) {
	    if (limitLen > 0) {
		Tcl_LimitSetCommands(slaveInterp, limit);
		Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_COMMANDS);
	    } else {
		Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_COMMANDS);
	    }
	}
	return TCL_OK;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * SlaveTimeLimitCmd --
 *
 *	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
SlaveTimeLimitCmd(
    Tcl_Interp *interp,			/* Current interpreter. */
    Tcl_Interp *slaveInterp,		/* 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
    };







|



|



|
|

|









|














|

|







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
4674
4675
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
    /*
     * 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 == slaveInterp) {
	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 = slaveInterp;
	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(slaveInterp,
		TCL_LIMIT_TIME)));

	if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) {
	    Tcl_Time limitMoment;

	    Tcl_LimitGetTime(slaveInterp, &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;








|










|


















|


|


|







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
4733
4734
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
    } 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 = slaveInterp;
	    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(slaveInterp, TCL_LIMIT_TIME)));
	    break;
	case OPT_MILLI:
	    if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) {
		Tcl_Time limitMoment;

		Tcl_LimitGetTime(slaveInterp, &limitMoment);
		Tcl_SetObjResult(interp,
			Tcl_NewWideIntObj(limitMoment.usec/1000));
	    }
	    break;
	case OPT_SEC:
	    if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) {
		Tcl_Time limitMoment;

		Tcl_LimitGetTime(slaveInterp, &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(slaveInterp, &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:







|











|


|


|





|


|

















|







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
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
		 * 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(slaveInterp, &limitMoment);
		Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_TIME);
	    } else {
		Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_TIME);
	    }
	}
	if (scriptObj != NULL) {
	    SetScriptLimitCallback(interp, TCL_LIMIT_TIME, slaveInterp,
		    (scriptLen > 0 ? scriptObj : NULL));
	}
	if (granObj != NULL) {
	    Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_TIME, gran);
	}
	return TCL_OK;
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







|
|

|



|



|












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
118
119
120
121
122
123
124
125
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LoadObjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
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 *slaveIntName = TclGetString(objv[3]);

	target = Tcl_GetSlave(interp, slaveIntName);
	if (target == NULL) {
	    code = TCL_ERROR;
	    goto done;
	}
    }

    /*







|

|







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
543
544
545
546
547
548
549
550
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UnloadObjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
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 *slaveIntName = TclGetString(objv[i + 2]);

	target = Tcl_GetSlave(interp, slaveIntName);
	if (target == NULL) {
	    return TCL_ERROR;
	}
    }

    /*
     * Scan through the packages that are currently loaded to see if the







|

|







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
1088
1089
1090
1091
1092
1093
1094
1095
		    Tcl_NewListObj(2, pkgDesc));
	}
	Tcl_MutexUnlock(&packageMutex);
	Tcl_SetObjResult(interp, resultObj);
	return TCL_OK;
    }

    target = Tcl_GetSlave(interp, targetName);
    if (target == NULL) {
	return TCL_ERROR;
    }
    ipPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL);

    /*
     * Return information about all of the available packages.







|







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
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
static int
NamespaceOriginCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Command command, origCommand;
    Tcl_Obj *resultPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name");
	return TCL_ERROR;
    }

    command = Tcl_GetCommandFromObj(interp, objv[1]);
    if (command == NULL) {











	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "invalid command name \"%s\"", TclGetString(objv[1])));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
		TclGetString(objv[1]), NULL);
	return TCL_ERROR;
    }
    origCommand = TclGetOriginalCommand(command);
    TclNewObj(resultPtr);
    if (origCommand == NULL) {
	/*
	 * The specified command isn't an imported command. Return the
	 * command's name qualified by the full name of the namespace it was
	 * defined in.
	 */

	Tcl_GetCommandFullName(interp, command, resultPtr);
    } else {
	Tcl_GetCommandFullName(interp, origCommand, resultPtr);
    }
    Tcl_SetObjResult(interp, resultPtr);
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * NamespaceParentCmd --
 *
 *	Invoked to implement the "namespace parent" command that returns the







|







|
|
>
>
>
>
>
>
>
>
>
>
>






<
<
<
<
<
<
<
<
<
<
<
<
<



>







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
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 master 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 " };";







|







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
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,
	    (ClientData) &tclOOStubs);
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOGetFoundation --
 *







|







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
569
570
571
572
573
574
575
576
 *	when the objects and classes themselves are destroyed.
 *
 * ----------------------------------------------------------------------
 */

static void
KillFoundation(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp)	/* The interpreter containing the OO system
			 * foundation. */
{
    Foundation *fPtr = GetFoundation(interp);

    TclDecrRefCount(fPtr->unknownMethodNameObj);
    TclDecrRefCount(fPtr->constructorName);







|







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
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_IS_DELETED) {
	/*
	 * 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







|







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
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 master [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));







|







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
174
175
176
177
178
179
180
181
 *	Implements [info object class $objName ?$className?]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoObjectClassCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;

    if (objc != 2 && objc != 3) {







|







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
231
232
233
234
235
236
237
238
 *	Implements [info object definition $objName $methodName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoObjectDefnCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    Tcl_HashEntry *hPtr;
    Proc *procPtr;







|







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
305
306
307
308
309
310
311
312
 *	Implements [info object filters $objName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoObjectFiltersCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    int i;
    Tcl_Obj *filterObj, *resultObj;
    Object *oPtr;







|







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
344
345
346
347
348
349
350
351
 *	Implements [info object forward $objName $methodName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoObjectForwardCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    Tcl_HashEntry *hPtr;
    Tcl_Obj *prefixObj;







|







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
401
402
403
404
405
406
407
408
 *	Implements [info object isa $category $objName ...]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoObjectIsACmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    static const char *const categories[] = {
	"class", "metaclass", "mixin", "object", "typeof", NULL
    };







|







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
520
521
522
523
524
525
526
527
 *	Implements [info object methods $objName ?$option ...?]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoObjectMethodsCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
    FOREACH_HASH_DECLS;







|







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
640
641
642
643
644
645
646
647
 *	Implements [info object methodtype $objName $methodName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoObjectMethodTypeCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    Tcl_HashEntry *hPtr;
    Method *mPtr;







|







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
697
698
699
700
701
702
703
704
 *	Implements [info object mixins $objName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoObjectMixinsCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *mixinPtr;
    Object *oPtr;
    Tcl_Obj *resultObj;







|







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
740
741
742
743
744
745
746
747
 *	Implements [info object creationid $objName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoObjectIdCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;

    if (objc != 2) {







|







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
772
773
774
775
776
777
778
779
 *	Implements [info object namespace $objName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoObjectNsCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;

    if (objc != 2) {







|







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
805
806
807
808
809
810
811
812
 *	Implements [info object variables $objName ?-private?]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoObjectVariablesCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    Tcl_Obj *resultObj;
    int i, isPrivate = 0;







|







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
859
860
861
862
863
864
865
866
 *	Implements [info object vars $objName ?$pattern?]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoObjectVarsCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    const char *pattern = NULL;
    FOREACH_HASH_DECLS;







|







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
920
921
922
923
924
925
926
927
 *	Implements [info class constructor $clsName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoClassConstrCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Proc *procPtr;
    CompiledLocal *localPtr;
    Tcl_Obj *resultObjs[2];







|







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
981
982
983
984
985
986
987
988
 *	Implements [info class definition $clsName $methodName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoClassDefnCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_HashEntry *hPtr;
    Proc *procPtr;
    CompiledLocal *localPtr;







|







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
1049
1050
1051
1052
1053
1054
1055
1056
 *	Implements [info class definitionnamespace $clsName ?$kind?]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoClassDefnNsCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    static const char *kindList[] = {
	"-class",
	"-instance",







|







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
1099
1100
1101
1102
1103
1104
1105
1106
 *	Implements [info class destructor $clsName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoClassDestrCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Proc *procPtr;
    Class *clsPtr;








|







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
1143
1144
1145
1146
1147
1148
1149
1150
 *	Implements [info class filters $clsName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoClassFiltersCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    int i;
    Tcl_Obj *filterObj, *resultObj;
    Class *clsPtr;







|







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
1181
1182
1183
1184
1185
1186
1187
1188
 *	Implements [info class forward $clsName $methodName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoClassForwardCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_HashEntry *hPtr;
    Tcl_Obj *prefixObj;
    Class *clsPtr;







|







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
1232
1233
1234
1235
1236
1237
1238
1239
 *	Implements [info class instances $clsName ?$pattern?]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoClassInstancesCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    Class *clsPtr;
    int i;







|







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
1280
1281
1282
1283
1284
1285
1286
1287
 *	Implements [info class methods $clsName ?options...?]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoClassMethodsCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
    Tcl_Obj *namePtr, *resultObj;
    Method *mPtr;







|







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
1396
1397
1398
1399
1400
1401
1402
1403
 *	Implements [info class methodtype $clsName $methodName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoClassMethodTypeCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_HashEntry *hPtr;
    Method *mPtr;
    Class *clsPtr;







|







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
1448
1449
1450
1451
1452
1453
1454
1455
 *	Implements [info class mixins $clsName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoClassMixinsCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr, *mixinPtr;
    Tcl_Obj *resultObj;
    int i;







|







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
1490
1491
1492
1493
1494
1495
1496
1497
 *	Implements [info class subclasses $clsName ?$pattern?]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoClassSubsCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr, *subclassPtr;
    Tcl_Obj *resultObj;
    int i;







|







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
1545
1546
1547
1548
1549
1550
1551
1552
 *	Implements [info class superclasses $clsName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoClassSupersCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr, *superPtr;
    Tcl_Obj *resultObj;
    int i;







|







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
1584
1585
1586
1587
1588
1589
1590
1591
 *	Implements [info class variables $clsName ?-private?]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoClassVariablesCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr;
    Tcl_Obj *resultObj;
    int i, isPrivate = 0;







|







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
1638
1639
1640
1641
1642
1643
1644
1645
 *	Implements [info object call $objName $methodName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoObjectCallCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    CallContext *contextPtr;








|







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
1684
1685
1686
1687
1688
1689
1690
1691
 *	Implements [info class call $clsName $methodName]
 *
 * ----------------------------------------------------------------------
 */

static int
InfoClassCallCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr;
    CallChain *callPtr;








|







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
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;		/* Master 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;	/* Master ::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







|











|







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
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));            \
    }

/*







|




|

















|








|
|

|
|







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
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(sizeof(ContLineLoc) + num*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







|







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
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) {
	return TCL_ERROR;
    }

    resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
    if ((objPtr->typePtr == &tclCmdNameType) && (resPtr->refCount == 1)) {
	/*
	 * Re-use existing ResolvedCmdName struct when possible.







|







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
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 "master 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







|







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
635

636
637
638
639
640
641
642
	    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;







|
>







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
1264
1265
1266
1267
1268
1269
1270
1271
1272

    /*
     * 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(sizeof(LocalCache)
	    + (localCt - 1) * sizeof(Tcl_Obj *)
	    + numArgs * sizeof(Var));

    namePtr = &localCachePtr->varName0;
    varPtr = (Var *) (namePtr + localCt);
    localPtr = procPtr->firstLocalPtr;
    while (localPtr) {
	if (TclIsVarTemporary(localPtr)) {







|
|







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
3457
3458
3459
3460
3461
3462
3463
3464
3465
Tcl_Obj *
TclStringFirst(
    Tcl_Obj *needle,
    Tcl_Obj *haystack,
    size_t start)
{
    size_t lh = 0, ln = Tcl_GetCharLength(needle);
    Tcl_Obj *result;
    size_t value = TCL_IO_FAILURE;
	Tcl_UniChar *check, *end, *uh, *un;

    if (start == TCL_INDEX_NONE) {
	start = 0;
    }
    if (ln == 0) {
	/* We don't find empty substrings.  Bizarre!







<
|







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
3535
3536
3537
3538
3539
3540
3541
3542
3543
	if ((*check == *un) && (0 ==
		memcmp(check + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) {
	    value =  (check - uh);
	    goto firstEnd;
	}
    }
  firstEnd:
    TclNewIntObj(result, TclWideIntFromSize(value));
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclStringLast --
 *







|
<







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
3564
3565
3566
3567
3568
3569
3570
3571
3572
Tcl_Obj *
TclStringLast(
    Tcl_Obj *needle,
    Tcl_Obj *haystack,
    size_t last)
{
    size_t lh = 0, ln = Tcl_GetCharLength(needle);
    Tcl_Obj *result;
    size_t value = TCL_IO_FAILURE;
	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







<
|







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
3622
3623
3624
3625
3626
3627
3628
3629
3630
		&& (0 == memcmp(check+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) {
	    value = (check - uh);
	    goto lastEnd;
	}
	check--;
    }
  lastEnd:
    TclNewIntObj(result, TclWideIntFromSize(value));
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclStringReverse --
 *







|
<







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
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[1];	/* The array of Unicode chars. The actual size
				 * of this field depends on the 'maxChars'
				 * field above. */
} String;

#define STRING_SIZE(numChars) \
    (sizeof(String) + ((numChars) * 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) \







|





|







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
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_CreateSlave, /* 97 */
    Tcl_CreateTimerHandler, /* 98 */
    Tcl_CreateTrace, /* 99 */
    Tcl_DeleteAssocData, /* 100 */
    Tcl_DeleteChannelHandler, /* 101 */
    Tcl_DeleteCloseHandler, /* 102 */
    Tcl_DeleteCommand, /* 103 */
    Tcl_DeleteCommandFromToken, /* 104 */







|







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
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_GetMaster, /* 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_GetSlave, /* 172 */
    Tcl_GetStdChannel, /* 173 */
    0, /* 174 */
    0, /* 175 */
    Tcl_GetVar2, /* 176 */
    0, /* 177 */
    0, /* 178 */
    Tcl_HideCommand, /* 179 */







|















|







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
730
731
732
733
734
735
736
737
 *	Creates, deletes, and invokes handlers.
 *
 *----------------------------------------------------------------------
 */

static int
TestasyncCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
941
942
943
944
945
946
947
948
    Tcl_ExitThread(TCL_OK);
    TCL_THREAD_CREATE_RETURN;
}
#endif

static int
TestbumpinterpepochObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Interp *iPtr = (Interp *)interp;

    if (objc != 1) {







|







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
976
977
978
979
980
981
982
983
 *	Creates and deletes various commands and modifies their data.
 *
 *----------------------------------------------------------------------
 */

static int
TestcmdinfoCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    Tcl_CmdInfo info;

    if (argc != 3) {







|







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
1103
1104
1105
1106
1107
1108
1109
1110
 *	Creates and deletes various commands and modifies their data.
 *
 *----------------------------------------------------------------------
 */

static int
TestcmdtokenCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    Tcl_Command token;
    int *l;
    char buf[30];







|







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
1166
1167
1168
1169
1170
1171
1172
1173
 *	a procedure by the command trace.
 *
 *----------------------------------------------------------------------
 */

static int
TestcmdtraceCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    Tcl_DString buffer;
    int result;








|







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
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(ClientData),
    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(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    TCL_UNUSED(int) /*level*/,
    TCL_UNUSED(char *) /*command*/,
    TCL_UNUSED(Tcl_CmdProc *),
    TCL_UNUSED(ClientData),
    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(ClientData),
    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. */
{







|

















|




|














|







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
1358
1359
1360
1361
1362
1363
1364
1365
 *	and "value:at:").
 *
 *----------------------------------------------------------------------
 */

static int
TestcreatecommandCmd(
    TCL_UNUSED(ClientData),
    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);







|







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
1388
1389
1390
1391
1392
1393
1394
1395
	return TCL_ERROR;
    }
    return TCL_OK;
}

static int
CreatedCommandProc(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    TCL_UNUSED(int) /*argc*/,
    TCL_UNUSED(const char **) /*argv*/)
{
    Tcl_CmdInfo info;
    int found;








|







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
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(ClientData),
    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
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
1448
1449
1450
1451
1452
1453
1454
1455
 *	Creates and deletes interpreters.
 *
 *----------------------------------------------------------------------
 */

static int
TestdcallCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    int i, id;

    delInterp = Tcl_CreateInterp();







|







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
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(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    DelCmd *dPtr;
    Tcl_Interp *slave;

    if (argc != 4) {
	Tcl_AppendResult(interp, "wrong # args", NULL);
	return TCL_ERROR;
    }

    slave = Tcl_GetSlave(interp, argv[1]);
    if (slave == 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(slave, argv[2], DelCmdProc, dPtr,
	    DelDeleteProc);
    return TCL_OK;
}

static int
DelCmdProc(
    void *clientData,	/* String result to return. */







|





|






|
|








|







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
1587
1588
1589
1590
1591
1592
1593
1594
 *	interpreter.
 *
 *----------------------------------------------------------------------
 */

static int
TestdelassocdataCmd(
    TCL_UNUSED(ClientData),
    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);







|







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
1624
1625
1626
1627
1628
1629
1630
1631
 *	shorten - Indicates that the 'shorten' flag should be passed in.
 *
 *-----------------------------------------------------------------------------
 */

static int
TestdoubledigitsObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp* interp,		/* Tcl interpreter */
    int objc,			/* Parameter count */
    Tcl_Obj* const objv[])	/* Parameter vector */
{
    static const char* options[] = {
	"shortest",
	"e",







|







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
1711
1712
1713
1714
1715
1716
1717
1718
 *	Creates, deletes, and invokes handlers.
 *
 *----------------------------------------------------------------------
 */

static int
TestdstringCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    int count;

    if (argc < 2) {







|







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
1837
1838
1839
1840
1841
1842
1843
1844
 *	Load encodings.
 *
 *----------------------------------------------------------------------
 */

static int
TestencodingObjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
1997
1998
1999
2000
2001
2002
2003
2004
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestevalexObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int length, flags;
    const char *script;








|







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
2042
2043
2044
2045
2046
2047
2048
2049
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestevalobjvObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int evalGlobal;

    if (objc < 3) {







|







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
2091
2092
2093
2094
2095
2096
2097
2098
 *	Manipulates the event queue as directed.
 *
 *----------------------------------------------------------------------
 */

static int
TesteventObjCmd(
    TCL_UNUSED(ClientData),
    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
    };







|







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
2270
2271
2272
2273
2274
2275
2276
2277
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestexithandlerCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    int value;

    if (argc != 3) {







|







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
2346
2347
2348
2349
2350
2351
2352
2353
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestexprlongCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
2389
2390
2391
2392
2393
2394
2395
2396
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestexprlongobjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
2431
2432
2433
2434
2435
2436
2437
2438
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestexprdoubleCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
2475
2476
2477
2478
2479
2480
2481
2482
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestexprdoubleobjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
2517
2518
2519
2520
2521
2522
2523
2524
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestexprstringCmd(
    TCL_UNUSED(ClientData),
    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);







|







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
2549
2550
2551
2552
2553
2554
2555
2556
 *	May create a link on disk.
 *
 *----------------------------------------------------------------------
 */

static int
TestfilelinkCmd(
    TCL_UNUSED(ClientData),
    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) {







|







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
2616
2617
2618
2619
2620
2621
2622
2623
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestgetassocdataCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    char *res;

    if (argc != 2) {







|







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
2654
2655
2656
2657
2658
2659
2660
2661
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestgetplatformCmd(
    TCL_UNUSED(ClientData),
    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;








|







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
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(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    Tcl_Interp *slaveToDelete;

    if (argc != 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" path\"", NULL);
	return TCL_ERROR;
    }
    slaveToDelete = Tcl_GetSlave(interp, argv[1]);
    if (slaveToDelete == NULL) {
	return TCL_ERROR;
    }
    Tcl_DeleteInterp(slaveToDelete);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestlinkCmd --







|




|






|
|


|







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
2734
2735
2736
2737
2738
2739
2740
2741
 *	values of the linked variables.
 *
 *----------------------------------------------------------------------
 */

static int
TestlinkCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
3202
3203
3204
3205
3206
3207
3208
3209
 *	Creates, deletes, and invokes variable links.
 *
 *----------------------------------------------------------------------
 */

static int
TestlinkarrayCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,         /* Current interpreter. */
    int objc,                   /* Number of arguments. */
    Tcl_Obj *const objv[])      /* Argument objects. */
{
    static const char *LinkOption[] = {
        "update", "remove", "create", NULL
    };







|







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
3320
3321
3322
3323
3324
3325
3326
3327
 *	Modifies the current C locale.
 *
 *----------------------------------------------------------------------
 */

static int
TestlocaleCmd(
    TCL_UNUSED(ClientData),
    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[] = {







|







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
3406
3407
3408
3409
3410
3411
3412
3413
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestparserObjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
3462
3463
3464
3465
3466
3467
3468
3469
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestexprparserObjCmd(
    TCL_UNUSED(ClientData),
    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
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
3609
3610
3611
3612
3613
3614
3615
3616
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestparsevarObjCmd(
    TCL_UNUSED(ClientData),
    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) {







|







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
3650
3651
3652
3653
3654
3655
3656
3657
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestparsevarnameObjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
3713
3714
3715
3716
3717
3718
3719
3720
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestpreferstableObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    TCL_UNUSED(int) /*objc*/,
    TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
    Interp *iPtr = (Interp *) interp;

    iPtr->packagePrefer = PKG_PREFER_STABLE;







|







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
3743
3744
3745
3746
3747
3748
3749
3750
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestprintObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    Tcl_WideInt argv1 = 0;
    size_t argv2;








|







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
3784
3785
3786
3787
3788
3789
3790
3791
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
TestregexpObjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
4109
4110
4111
4112
4113
4114
4115
4116
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
TestreturnObjCmd(
    TCL_UNUSED(ClientData),
    TCL_UNUSED(Tcl_Interp *),
    TCL_UNUSED(int) /*objc*/,
    TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
    return TCL_RETURN;
}








|







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
4137
4138
4139
4140
4141
4142
4143
4144
 *	data for this interpreter.
 *
 *----------------------------------------------------------------------
 */

static int
TestsetassocdataCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    char *buf, *oldData;
    Tcl_InterpDeleteProc *procPtr;








|







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
4188
4189
4190
4191
4192
4193
4194
4195
 *	Sets the tclPlatform global variable.
 *
 *----------------------------------------------------------------------
 */

static int
TestsetplatformCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    size_t length;
    TclPlatformType *platform;








|







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
4237
4238
4239
4240
4241
4242
4243
4244
 *	variable "x" in that interpreter is set to "loaded".
 *
 *----------------------------------------------------------------------
 */

static int
TeststaticpkgCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    int safe, loaded;

    if (argc != 4) {







|







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
4288
4289
4290
4291
4292
4293
4294
4295
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TesttranslatefilenameCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    Tcl_DString buffer;
    const char *result;








|







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
4329
4330
4331
4332
4333
4334
4335
4336
 *	Creates or modifies an "upvar" reference.
 *
 *----------------------------------------------------------------------
 */

static int
TestupvarCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    int flags = 0;

    if ((argc != 5) && (argc != 6)) {







|







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
4381
4382
4383
4384
4385
4386
4387
4388
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestseterrorcodeCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
4433
4434
4435
4436
4437
4438
4439
4440
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestsetobjerrorcodeCmd(
    TCL_UNUSED(ClientData),
    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;
}







|







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
4461
4462
4463
4464
4465
4466
4467
4468
 *	Creates and deletes interpreters.
 *
 *----------------------------------------------------------------------
 */

static int
TestfeventCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
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(ClientData),
    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(ClientData),
    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;







|


















|







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
4634
4635
4636
4637
4638
4639
4640
4641
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestgetvarfullnameCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
4708
4709
4710
4711
4712
4713
4714
4715
 *	Allocates and frees memory, sets a variable "a" in the interpreter.
 *
 *----------------------------------------------------------------------
 */

static int
GetTimesObjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
4887
4888
4889
4890
4891
4892
4893
4894
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
NoopCmd(
    TCL_UNUSED(ClientData),
    TCL_UNUSED(Tcl_Interp *),
    TCL_UNUSED(int) /*argc*/,
    TCL_UNUSED(const char **) /*argv*/)
{
    return TCL_OK;
}








|







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
4914
4915
4916
4917
4918
4919
4920
4921
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
NoopObjCmd(
    TCL_UNUSED(ClientData),
    TCL_UNUSED(Tcl_Interp *),
    TCL_UNUSED(int) /*objc*/,
    TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
    return TCL_OK;
}








|







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
4939
4940
4941
4942
4943
4944
4945
4946
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TeststringbytesObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    int n;
    const unsigned char *p;








|







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
4979
4980
4981
4982
4983
4984
4985
4986
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestpurebytesobjObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    Tcl_Obj *objPtr;

    if (objc > 2) {







|







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
5026
5027
5028
5029
5030
5031
5032
5033
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestsetbytearraylengthObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    int n;
    Tcl_Obj *obj = NULL;








|







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
5070
5071
5072
5073
5074
5075
5076
5077
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestbytestringObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    size_t n = 0;
    const char *p;








|







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
5192
5193
5194
5195
5196
5197
5198
5199
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestsaveresultCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
5319
5320
5321
5322
5323
5324
5325
5326
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestmainthreadCmd(
    TCL_UNUSED(ClientData),
    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());








|







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
5380
5381
5382
5383
5384
5385
5386
5387
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestsetmainloopCmd(
    TCL_UNUSED(ClientData),
    TCL_UNUSED(Tcl_Interp *),
    TCL_UNUSED(int) /*argc*/,
    TCL_UNUSED(const char **) /*argv*/)
{
    exitMainLoop = 0;
    Tcl_SetMainLoop(MainLoop);
    return TCL_OK;







|







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
5409
5410
5411
5412
5413
5414
5415
5416
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestexitmainloopCmd(
    TCL_UNUSED(ClientData),
    TCL_UNUSED(Tcl_Interp *),
    TCL_UNUSED(int) /*argc*/,
    TCL_UNUSED(const char **) /*argv*/)
{
    exitMainLoop = 1;
    return TCL_OK;
}







|







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
5437
5438
5439
5440
5441
5442
5443
5444
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestChannelCmd(
    TCL_UNUSED(ClientData),
    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. */







|







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
5904
5905
5906
5907
5908
5909
5910
5911
 *	Creates, deletes and returns channel event handlers.
 *
 *----------------------------------------------------------------------
 */

static int
TestChannelEventCmd(
    TCL_UNUSED(ClientData),
    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 */







|







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
6116
6117
6118
6119
6120
6121
6122
6123
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestSocketCmd(
    TCL_UNUSED(ClientData),
    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. */








|







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
6187
6188
6189
6190
6191
6192
6193
6194
 *	May change the ServiceMode setting.
 *
 *----------------------------------------------------------------------
 */

static int
TestServiceModeCmd(
    TCL_UNUSED(ClientData),
    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],







|







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
6231
6232
6233
6234
6235
6236
6237
6238
 *	Sets interpreter result.
 *
 *----------------------------------------------------------------------
 */

static int
TestWrongNumArgsObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int i, length;
    const char *msg;








|







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
6287
6288
6289
6290
6291
6292
6293
6294
 *	Sets interpreter result.
 *
 *----------------------------------------------------------------------
 */

static int
TestGetIndexFromObjStructObjCmd(
    TCL_UNUSED(ClientData),
    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
    };







|







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
6341
6342
6343
6344
6345
6346
6347
6348
 *	Inserts or removes a filesystem from Tcl's stack.
 *
 *----------------------------------------------------------------------
 */

static int
TestFilesystemObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    int res, boolVal;
    const char *msg;








|







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
6683
6684
6685
6686
6687
6688
6689
6690
    TestReport("normalizepath", pathPtr, NULL);
    return nextCheckpoint;
}

static int
SimplePathInFilesystem(
    Tcl_Obj *pathPtr,
    TCL_UNUSED(ClientData *))
{
    const char *str = Tcl_GetString(pathPtr);

    if (strncmp(str, "simplefs:/", 10)) {
	return -1;
    }
    return TCL_OK;







|







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
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(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    int res, boolVal;
    const char *msg;








|







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
6975
6976
6977
6978
6979
6980
6981
6982

/*
 * Used to check correct string-length determining in Tcl_NumUtfChars
 */

static int
TestNumUtfCharsCmd(
    TCL_UNUSED(ClientData),
    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]);







|







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
7005
7006
7007
7008
7009
7010
7011
7012

/*
 * Used to check correct operation of Tcl_UtfFindFirst
 */

static int
TestFindFirstCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    if (objc > 1) {
	int len = -1;








|







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
7027
7028
7029
7030
7031
7032
7033
7034

/*
 * Used to check correct operation of Tcl_UtfFindLast
 */

static int
TestFindLastCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    if (objc > 1) {
	int len = -1;








|







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
7069
7070
7071
7072
7073
7074
7075
7076
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestcpuidCmd(
    TCL_UNUSED(ClientData),
    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];







|







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
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(ClientData),
    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







|







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
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(ClientData),
    Tcl_Interp *interp,
    int argc,
    const char **argv)
{
    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args", NULL);
	return TCL_ERROR;







|







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
7208
7209
7210
7211
7212
7213
7214
7215
}

/*
 * Used for determining sizeof(long) at script level.
 */
static int
TestlongsizeCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,
    int argc,
    TCL_UNUSED(const char **) /*argv*/)
{
    if (argc != 1) {
	Tcl_AppendResult(interp, "wrong # args", NULL);
	return TCL_ERROR;







|







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
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(ClientData),
    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(ClientData),
    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;







|

















|







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
7324
7325
7326
7327
7328
7329
7330
7331
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestconcatobjCmd(
    TCL_UNUSED(ClientData),
    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];







|







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
7620
7621
7622
7623
7624
7625
7626
7627
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestgetencpathObjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
7653
7654
7655
7656
7657
7658
7659
7660
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestsetencpathObjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
7687
7688
7689
7690
7691
7692
7693
7694
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestparseargsCmd(
    TCL_UNUSED(ClientData),
    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];







|







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
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(ClientData),
    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_GetSlave(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) {







|















|







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
144
145
146
147
148
149
150
151
 *	type.
 *
 *----------------------------------------------------------------------
 */

static int
TestbignumobjCmd(
    TCL_UNUSED(ClientData),
    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
    };







|







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
343
344
345
346
347
348
349
350
 *	have boolean type.
 *
 *----------------------------------------------------------------------
 */

static int
TestbooleanobjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
443
444
445
446
447
448
449
450
 *	have double type.
 *
 *----------------------------------------------------------------------
 */

static int
TestdoubleobjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
561
562
563
564
565
566
567
568
 *	have int type.
 *
 *----------------------------------------------------------------------
 */

static int
TestindexobjCmd(
    TCL_UNUSED(ClientData),
    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};







|







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
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", INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT),
	    &index);
    Tcl_Free((void *)argv);
    if (result == TCL_OK) {
	Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
    }
    return result;
}







|







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
651
652
653
654
655
656
657
658
 *	have int type.
 *
 *----------------------------------------------------------------------
 */

static int
TestintobjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
855
856
857
858
859
860
861
862
 *	Creates, manipulates and frees list objects.
 *
 *-----------------------------------------------------------------------------
 */

static int
TestlistobjCmd(
    TCL_UNUSED(ClientData),
    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",







|







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
952
953
954
955
956
957
958
959
 *	Creates and frees objects.
 *
 *----------------------------------------------------------------------
 */

static int
TestobjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
1164
1165
1166
1167
1168
1169
1170
1171
 *	have string type.
 *
 *----------------------------------------------------------------------
 */

static int
TeststringobjCmd(
    TCL_UNUSED(ClientData),
    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







|







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
231
232
233
234
235
236
237
238
 *  Leaves an error message in the interp's result on error.
 *
 *----------------------------------------------------------------------
 */

static int
ProcBodyTestProcObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* the current interpreter */
    int objc,			/* argument count */
    Tcl_Obj *const objv[])	/* arguments */
{
    const char *fullName;
    Tcl_Command procCmd;
    Command *cmdPtr;







|







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
330
331
332
333
334
335
336
337
 *  Returns a standard Tcl code.
 *
 *----------------------------------------------------------------------
 */

static int
ProcBodyTestCheckObjCmd(
    TCL_UNUSED(ClientData),
    Tcl_Interp *interp,		/* the current interpreter */
    int objc,			/* argument count */
    Tcl_Obj *const objv[])	/* arguments */
{
    const char *version;

    if (objc != 1) {







|







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
208
209
210
211
212
213
214
215
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadObjCmd(
    TCL_UNUSED(ClientData),
    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[] = {







|







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
1108
1109
1110
1111
1112
1113
1114
1115
 *
 *------------------------------------------------------------------------
 */

static int
ThreadDeleteEvent(
    Tcl_Event *eventPtr,	/* Really ThreadEvent */
    TCL_UNUSED(ClientData))
{
    if (eventPtr->proc == ThreadEventProc) {
	Tcl_Free(((ThreadEvent *) eventPtr)->script);
	return 1;
    }

    /*







|







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
186
187
188
189
190
191
192
193
 * Side effects:
 *	See the user documentation.
 *----------------------------------------------------------------------
 */

int
Tcl_TraceObjCmd(
    TCL_UNUSED(ClientData),
    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;







|







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
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) && (interp != NULL)) {
				goto extreme;
			    }
			    w2 = -w2;
			}

			if ((w1 ^ w2) < 0) {
			    /* Different signs, sum cannot overflow */







|







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
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558

3559





3560
3561
3562
3563
3564
3565
3566
			} else {
			    if (w1 > WIDE_MIN - w2) {
				offset = w1 + w2;
			    } else {
				offset = WIDE_MIN;
			    }
			}
		    } else if (interp == NULL) {
			/*
			 * We use an interp to do bignum index calculations.
			 * If we don't get one, call all indices with bignums errors,
			 * and rely on callers to handle it.
			 */
			goto parseError;
		    } else {
			/*
			 * At least one is big, do bignum math. Little reason to
			 * value performance here. Re-use code.  Parse has verified
			 * objPtr is an expression. Compute it.
			 */

			Tcl_Obj *sum;

		    extreme:

			Tcl_ExprObj(interp, objPtr, &sum);





			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 */







<
<
<
<
<
<
<










>
|
>
>
>
>
>







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
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 master, 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"







|







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
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 master, 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
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
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.3

namespace eval http {
    # Allow resourcing to not clobber existing data

    variable http
    if {![info exists http]} {
	array set http {













|







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
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 != -1} {
	    incr ndx -1
	    set connId [lindex $map $ndx]
	}
    }
    if {    ($connId ne {})
	 && [info exists socketMapping($connId)]
	 && ($socketMapping($connId) eq $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
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
	# work properly.
	fconfigure $state(-querychannel) -blocking 1 -translation binary
	set contDone 0
    }
    if {[info exists state(-method)] && ($state(-method) ne "")} {
	set how $state(-method)
    }
    # We cannot handle chunked encodings with -handler, so force HTTP/1.0
    # until we can manage this.
    if {[info exists state(-handler)]} {
	set state(-protocol) 1.0
    }
    set accept_types_seen 0

    Log ^B$tk begin sending request - token $token

    if {[catch {
	set state(method) $how
	puts $sock "$how $srvurl HTTP/$state(-protocol)"







<
<
<
<
<







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
1385
1386
1387
1388
1389
1390
1391
1392






1393
1394
1395


1396
1397
1398
1399
1400
1401
1402
	    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 {[info exists phost] && ($phost ne "") && $state(-keepalive)} {
	    puts $sock "Proxy-Connection: Keep-Alive"
	}


	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







|







>
>
>
>
>
>
|
|

>
>







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



1671
1672







































1673
1674
1675
1676
1677
1678
1679
    #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



    fileevent $sock readable ${token}EventCoroutine
}








































# 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







>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







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
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750

2751
2752
2753
2754
2755
2756
2757
			    # 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] == -1} {
				# Not a comma-separated list, not "close",
				# therefore "keep-alive".
				set tmpHeader keep-alive
			    } else {
				set tmpHeader keep-alive
				set tmpCsl [split $tmpHeader ,]
				# Optional whitespace either side of separator.
				foreach el $tmpCsl {
				    if {[string trim $el] eq {close}} {
					set tmpHeader close
					break
				    }
			        }

			    }
			    set state(connection) $tmpHeader
			}
			set-cookie {
			    if {$http(-cookiejar) ne ""} {
				ParseCookie $token [string trim $value]
			    }







|




|




|



>







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
2
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
package ifneeded http 2.9.3 [list tclPkgSetup $dir http 2.9.3 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]

|
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
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 + [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]} {







|







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
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] != -1} {
	    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"
	    }







|







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
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 master
      # package index
      if {$trace} { puts "[file dirname $pkgidxfile] Arbitrary code $thisline" }
      return {source [file join $dir pkgIndex.tcl]}
    }
    append buffer $thisline \n
    set thisline {}
  }







|







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
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.3  {http http.tcl}
    1 msgcat          1.7.1  {msgcat msgcat.tcl}
    1 opt             0.4.7  {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







|

|







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
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.7

namespace eval ::tcl {

    # Exported APIs
    namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
             OptProc OptProcArgGiven OptParse \
	     Lempty Lget \













|







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
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 slaves"}
            {-nestedloading2 -boolean true "OK to load into nested slaves"}
            {-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"}







|
|







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
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.7 [list source [file join $dir optparse.tcl]]











|
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
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 slave 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]]
	}







|







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
482
483

484



485
486
487
488
489
490
491
	# 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

	# we can't use glob in safe interps, so enclose the following in a
	# catch statement, where we get the pkgIndex files out of the

	# subdirectories



	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







<
|
>
|
>
>
>







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
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
# slave. It runs in a master interpreter and sets up data structure and
# aliases that will be invoked when used from a slave 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.7

# Create the safe namespace
namespace eval ::safe {
    # Exported API:
    namespace export interpCreate interpInit interpConfigure interpDelete \
	interpAddToAccessPath interpFindInAccessPath setLogCmd
}




|
|
















|







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

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
#  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]

    InterpCreate $slave $accessPath \
	[InterpStatics] [InterpNested] $deleteHook
}

proc ::safe::interpInit {args} {
    set Args [::tcl::OptKeyParse ::safe::interpIC $args]
    if {![::interp exists $slave]} {
	return -code error "\"$slave\" is not an interpreter"
    }

    InterpInit $slave $accessPath \
	[InterpStatics] [InterpNested] $deleteHook
}

# Check that the given slave is "one of us"
proc ::safe::CheckInterp {slave} {
    namespace upvar ::safe S$slave state
    if {![info exists state] || ![::interp exists $slave]} {
	return -code error \
	    "\"$slave\" 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







>
|





|
|

>
|



|
|
|
|

|







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
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
# 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 "slave" is our given argument because it also
	    # checks for the "-help" option.
	    set Args [::tcl::OptKeyParse ::safe::interpIC $args]
	    CheckInterp $slave
	    namespace upvar ::safe S$slave state

	    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 slave 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 $slave
	    namespace upvar ::safe S$slave state

	    set item [::tcl::OptCurDesc $desc]
	    set name [::tcl::OptName $item]
	    switch -exact -- $name {
		-accessPath {
		    return [list -accessPath $state(access_path)]
		}







|


|
|










|










|
|







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
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
		}
	    }
	}
	default {
	    # Otherwise we want to parse the arguments like init and
	    # create did
	    set Args [::tcl::OptKeyParse ::safe::interpIC $args]
	    CheckInterp $slave
	    namespace upvar ::safe S$slave state

	    # Get the current (and not the default) values of whatever has
	    # not been given:
	    if {![::tcl::OptProcArgGiven -accessPath]} {
		set doreset 1
		set accessPath $state(access_path)
	    } else {
		set doreset 0
	    }
	    if {
		![::tcl::OptProcArgGiven -statics]
		&& ![::tcl::OptProcArgGiven -noStatics]
	    } then {
		set statics    $state(staticsok)
	    } else {







|
|




|


|







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
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
	    } else {
		set nested     $state(nestedok)
	    }
	    if {![::tcl::OptProcArgGiven -deleteHook]} {
		set deleteHook $state(cleanupHook)
	    }
	    # we can now reconfigure :
	    InterpSetConfig $slave $accessPath $statics $nested $deleteHook
	    # auto_reset the slave (to completly synch the new access_path)
	    if {$doreset} {
		if {[catch {::interp eval $slave {auto_reset}} msg]} {
		    Log $slave "auto_reset failed: $msg"
		} else {
		    Log $slave "successful auto_reset" NOTICE
		}
	    }



















	}
    }
}

####
#
#  Functions that actually implements the exported APIs
#
####

#
# safe::InterpCreate : doing the real job
#
# This procedure creates a safe slave and initializes it with the safe
# base aliases.
# NB: slave name must be simple alphanumeric string, no spaces, no (), no
# {},...  {because the state array is stored as part of the name}
#
# Returns the slave name.
#
# Optional Arguments :
# + slave name : if empty, generated name will be used
# + access_path: path list controlling where load/source can occur,
#                if empty: the master auto_path will be used.
# + 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 {
			   slave
			   access_path
			   staticsok
			   nestedok
			   deletehook
		       } {
    # Create the slave.


    if {$slave ne ""} {
	::interp create -safe $slave
    } else {
	# empty argument: generate slave name
	set slave [::interp create -safe]
    }
    Log $slave "Created" NOTICE

    # Initialize it. (returns slave name)
    InterpInit $slave $access_path $staticsok $nestedok $deletehook
}

#
# InterpSetConfig (was setAccessPath) :
#    Sets up slave virtual auto_path and corresponding structure within
#    the master. Also sets the tcl_library in the slave to be the first
#    directory in the path.
#    NB: If you change the path after the slave has been initialized you
#    probably need to call "auto_reset" in the slave in order that it gets
#    the right auto_index() array values.

proc ::safe::InterpSetConfig {slave 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 == -1} {
	    # not found, add it.
	    set access_path [linsert $access_path 0 [info library]]
	    Log $slave "tcl_library was not in auto_path,\
			added it to slave's access_path" NOTICE
	} elseif {$where != 0} {
	    # not first, move it first
	    set access_path [linsert \
				 [lreplace $access_path $where $where] \
				 0 [info library]]
	    Log $slave "tcl_libray was not in first in auto_path,\
			moved it to front of slave's access_path" NOTICE
	}

	# Add 1st level sub dirs (will searched by auto loading from tcl
	# code in the slave using glob and thus fail, so we add them here
	# so by default it works the same).
	set access_path [AddSubDirs $access_path]
    }

    Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\
		nestedok=$nestedok deletehook=($deletehook)" NOTICE

    namespace upvar ::safe S$slave state

    # clear old autopath if it existed
    # build new one
    # Extend the access list with the paths used to look for Tcl Modules.
    # We save the virtual form separately as well, as syncing it with the
    # slave has to be defered until the necessary commands are present for
    # setup.

    set norm_access_path  {}
    set slave_access_path {}
    set map_access_path   {}
    set remap_access_path {}
    set slave_tm_path     {}

    set i 0
    foreach dir $access_path {
	set token [PathToken $i]
	lappend slave_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]

    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]} {






		continue
	    }

	    set token [PathToken $i]
	    lappend access_path        $dir
	    lappend slave_access_path  $token
	    lappend map_access_path    $token $dir
	    lappend remap_access_path  $dir $token
	    lappend norm_access_path   [file normalize $dir]




	    lappend slave_tm_path $token

	    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 state(access_path)       $access_path
    set state(access_path,map)   $map_access_path
    set state(access_path,remap) $remap_access_path
    set state(access_path,norm)  $norm_access_path
    set state(access_path,slave) $slave_access_path
    set state(tm_path_slave)     $slave_tm_path
    set state(staticsok)         $staticsok
    set state(nestedok)          $nestedok
    set state(cleanupHook)       $deletehook

    SyncAccessPath $slave

}

#
#
# FindInAccessPath:
#    Search for a real directory and returns its virtual Id (including the
#    "$")
proc ::safe::interpFindInAccessPath {slave path} {

    namespace upvar ::safe S$slave state

    if {![dict exists $state(access_path,remap) $path]} {
	return -code error "$path not found in access path $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 {slave path} {
    # first check if the directory is already in there
    # (inlined interpFindInAccessPath).

    namespace upvar ::safe S$slave 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,slave) $token
    lappend state(access_path,map)   $token $path
    lappend state(access_path,remap) $path $token
    lappend state(access_path,norm)  [file normalize $path]

    SyncAccessPath $slave
    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 {
			 slave
			 access_path
			 staticsok
			 nestedok
			 deletehook
		     } {
    # Configure will generate an access_path when access_path is empty.
    InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook

    # NB we need to add [namespace current], aliases are always absolute
    # paths.

    # These aliases let the slave load files to define new commands
    # This alias lets the slave use the encoding names, convertfrom,
    # convertto, and system, but not "encoding system <name>" to set the
    # system encoding.
    # Handling Tcl Modules, we need a restricted form of Glob.
    # This alias interposes on the 'exit' command and cleanly terminates
    # the slave.

    foreach {command alias} {
	source   AliasSource
	load     AliasLoad
	exit     interpDelete
	glob     AliasGlob
    } {
	::interp alias $slave $command {} [namespace current]::$alias $slave
    }

    # UGLY POINT! These commands are safe (they're ensembles with unsafe
    # subcommands), but is assumed to not be by existing policies so it is
    # hidden by default. Hack it...
    foreach command {encoding file} {
	::interp alias $slave $command {} interp invokehidden $slave $command
    }

    # This alias lets the slave have access to a subset of the 'file'
    # command functionality.

    foreach subcommand {dirname extension rootname tail} {
	::interp alias $slave ::tcl::file::$subcommand {} \
	    ::safe::AliasFileSubcommand $slave $subcommand
    }

    # Subcommand of 'encoding' that has special handling; [encoding system] is
    # OK provided it has no other arguments passed to it.
    ::interp alias $slave ::tcl::encoding::system {} \
	::safe::AliasEncodingSystem $slave

    # Subcommands of info
    ::interp alias $slave ::tcl::info::nameofexecutable {} \
	::safe::AliasExeName $slave

    # The allowed slave variables already have been set by Tcl_MakeSafe(3)

    # Source init.tcl and tm.tcl into the slave, to get auto_load and
    # other procedures defined:

    if {[catch {::interp eval $slave {
	source [file join $tcl_library init.tcl]
    }} msg opt]} {
	Log $slave "can't source init.tcl ($msg)"
	return -options $opt "can't source init.tcl into slave $slave ($msg)"
    }

    if {[catch {::interp eval $slave {
	source [file join $tcl_library tm.tcl]
    }} msg opt]} {
	Log $slave "can't source tm.tcl ($msg)"
	return -options $opt "can't source tm.tcl into slave $slave ($msg)"
    }

    # Sync the paths used to search for Tcl modules. This can be done only
    # now, after tm.tcl was loaded.
    namespace upvar ::safe S$slave state
    if {[llength $state(tm_path_slave)] > 0} {
	::interp eval $slave [list \
		::tcl::tm::add {*}[lreverse $state(tm_path_slave)]]
    }
    return $slave
}

# 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 {}







|
|

|
|

|

|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>













|

|


|


|

|







|





|
>
>
|
|

|
|

|

|
|




|
|

|
|


|









|


|
|





|
|



|




|


|





|



|


|




|







>








>
>
>
>
>
>





|



>
>
>
>
|
>










>






|
|




|
>







|
>
|


|









|


>
|









|




|







|






|




|
|




|







|






|


|



|
|




|
|


|
|

|

|


|


|
|


|


|
|




|
|
|
|

|







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
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
		}
	    }
	}
    }
    return $res
}

# This procedure deletes a safe slave managed by Safe Tcl and cleans up
# associated state:




proc ::safe::interpDelete {slave} {
    Log $slave "About to delete" NOTICE


    namespace upvar ::safe S$slave state












    # If the slave 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 $slave
	    } on error err {
		Log $slave "Delete hook error ($err)"
	    }
	}
    }

    # Discard the global array of state associated with the slave, 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 $slave]} {
	::interp delete $slave
	Log $slave "Deleted" NOTICE
    }

    return
}

# Set (or get) the logging mecanism








|
|
>
>
>

|
|

>
|

>
>
>
>
>
>
>
>
>
>
>
|










|

|




|








|
|
|







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
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
    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 {slave msg {type ERROR}} {
	    variable Log
	    {*}$Log "$type for slave $slave : $msg"
	    return
	}
    }
}

# ------------------- END OF PUBLIC METHODS ------------

#
# Sets the slave auto_path to the master recorded value.  Also sets
# tcl_library to the first token of the virtual path.
#
proc ::safe::SyncAccessPath {slave} {
    namespace upvar ::safe S$slave state

    set slave_access_path $state(access_path,slave)
    ::interp eval $slave [list set auto_path $slave_access_path]

    Log $slave "auto_path in $slave has been set to $slave_access_path"\
	NOTICE

    # This code assumes that info library is the first element in the
    # list of auto_path's. See -> InterpSetConfig for the code which
    # ensures this condition.

    ::interp eval $slave [list \
	      set tcl_library [lindex $slave_access_path 0]]
}

# 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 {slave path} {
    namespace upvar ::safe S$slave 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 {slave 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 {slave subcommand name} {
    if {[string match ~* $name]} {
	set name ./$name
    }
    tailcall ::interp invokehidden $slave tcl:file:$subcommand $name
}

# AliasGlob is the target of the "glob" alias in safe interpreters.

proc ::safe::AliasGlob {slave args} {
    Log $slave "GLOB ! $args" NOTICE
    set cmd {}
    set at 0
    array set got {
	-directory 0
	-nocomplain 0
	-join 0
	-tails 0







|

|








|


|
|

|
|

|






|
|












|
|














|




















|



|




|
|







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
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
    }

    set dir        {}
    set virtualdir {}

    while {$at < [llength $args]} {
	switch -glob -- [set opt [lindex $args $at]] {
	    -nocomplain - -- - -join - -tails {
		lappend cmd $opt
		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
	    }
	    pkgIndex.tcl {
		# Oops, this is globbing a subdirectory in regular package
		# search. That is not wanted. Abort, handler does catch
		# already (because glob was not defined before). See
		# package.tcl, lines 484ff in tclPkgUnknown.
		return -code error "unknown command glob"
	    }
	    -* {
		Log $slave "Safe base rejecting glob option '$opt'"
		return -code error "Safe base rejecting glob option '$opt'"
	    }
	    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 slave. Done after basic argument processing so that
    # we know if -nocomplain is set.
    if {$got(-directory)} {
	try {
	    set dir [TranslatePath $slave $virtualdir]
	    DirInAccessPath $slave $dir
	} on error msg {
	    Log $slave $msg
	    if {$got(-nocomplain)} return
	    return -code error "permission denied"
	}



	lappend cmd -directory $dir
    }









    # Apply the -join semantics ourselves
    if {$got(-join)} {
	set args [lreplace $args $at end [join [lrange $args $at end] "/"]]
    }


    # Process remaining pattern arguments

    set firstPattern [llength $cmd]
    foreach opt [lrange $args $at end] {
	if {![regexp $dirPartRE $opt -> thedir thefile]} {
	    set thedir .
	} elseif {[string match ~* $thedir]} {
	    set thedir ./$thedir
	}




	if {$thedir eq "*" &&
		($thefile eq "pkgIndex.tcl" || $thefile eq "*.tm")} {
	    set mapped 0
	    foreach d [glob -directory [TranslatePath $slave $virtualdir] \
			   -types d -tails *] {
		catch {
		    DirInAccessPath $slave \
			[TranslatePath $slave [file join $virtualdir $d]]
		    lappend cmd [file join $d $thefile]
		    set mapped 1
		}
	    }
	    if {$mapped} continue




	}














	try {
	    DirInAccessPath $slave [TranslatePath $slave \
		    [file join $virtualdir $thedir]]
	} on error msg {
	    Log $slave $msg
	    if {$got(-nocomplain)} continue
	    return -code error "permission denied"
	}
	lappend cmd $opt
    }

    Log $slave "GLOB = $cmd" NOTICE

    if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} {
	return
    }
    try {







	set entries [::interp invokehidden $slave glob {*}$cmd]
    } on error msg {


	Log $slave $msg
	return -code error "script error"
    }

    Log $slave "GLOB < $entries" NOTICE

    # Translate path back to what the slave 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 $slave "GLOB > $res" NOTICE
    return $res
}

# AliasSource is the target of the "source" alias in safe interpreters.

proc ::safe::AliasSource {slave 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 $slave "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 $slave "$msg ($args)"
	return -code error $msg
    }
    set file [lindex $args $at]

    # get the real path from the virtual one.
    if {[catch {
	set realfile [TranslatePath $slave $file]
    } msg]} {
	Log $slave $msg
	return -code error "permission denied"
    }

    # check that the path is in the access path of that slave
    if {[catch {
	FileInAccessPath $slave $realfile
    } msg]} {
	Log $slave $msg
	return -code error "permission denied"
    }

    # do the checks on the filename :



    if {[catch {
	CheckFileName $slave $realfile
    } msg]} {
	Log $slave "$realfile:$msg"
	return -code error $msg
    }

    # Passed all the tests, lets source it. Note that we do this all manually
    # because we want to control [info script] in the slave so information
    # doesn't leak so much. [Bug 2913625]
    set old [::interp eval $slave {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 $slave [list info script $file]
    } msg opt]
    if {$code == 0} {
	set code [catch {::interp eval $slave $contents} msg opt]
	set replacementMsg $msg
    }
    catch {interp eval $slave [list info script $old]}
    # Note that all non-errors are fine result codes from [source], so we must
    # take a little care to do it properly. [Bug 2923613]
    if {$code == 1} {
	Log $slave $msg
	return -code error $replacementMsg
    }
    return -code $code -options $opt $msg
}

# AliasLoad is the target of the "load" alias in safe interpreters.

proc ::safe::AliasLoad {slave file args} {
    set argc [llength $args]
    if {$argc > 2} {
	set msg "load error: too many arguments"
	Log $slave "$msg ($argc) {$file $args}"
	return -code error $msg
    }

    # package name (can be empty if file is not).
    set package [lindex $args 0]

    namespace upvar ::safe S$slave state

    # 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 $slave "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 $slave $msg
	    return -code error $msg
	}
	if {!$state(staticsok)} {
	    Log $slave "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 $slave $file]
	} on error msg {
	    Log $slave $msg
	    return -code error "permission denied"
	}

	# check the translated path
	try {
	    FileInAccessPath $slave $file
	} on error msg {
	    Log $slave $msg
	    return -code error "permission denied (path)"
	}
    }

    try {
	return [::interp invokehidden $slave load $file $package $target]
    } on error msg {







	Log $slave $msg
	return -code error $msg
    }
}

# FileInAccessPath raises an error if the file is not found in the list of
# directories contained in the (master side recorded) slave's access path.

# the security here relies on "file dirname" answering the proper
# result... needs checking ?
proc ::safe::FileInAccessPath {slave file} {
    namespace upvar ::safe S$slave 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 S$slave state
    if {$norm_parent ni $state(access_path,norm)} {
	return -code error "\"$file\": not in access_path"
    }
}

proc ::safe::DirInAccessPath {slave dir} {
    namespace upvar ::safe S$slave state
    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 S$slave 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 {slave command subcommand args} {
    set msg "not allowed to invoke subcommand $subcommand of $command"
    Log $slave $msg
    return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg
}

# AliasEncodingSystem is the target of the "encoding system" alias in safe
# interpreters.
proc ::safe::AliasEncodingSystem {slave args} {
    try {
	# Must not pass extra arguments; safe slaves may not set the system
	# encoding but they may read it.
	if {[llength $args]} {
	    return -code error -errorcode {TCL WRONGARGS} \
		"wrong # args: should be \"encoding system\""
	}
    } on error {msg options} {
	Log $slave $msg
	return -options $options $msg
    }
    tailcall ::interp invokehidden $slave tcl:encoding:system
}

# Various minor hiding of platform features. [Bug 2913625]

proc ::safe::AliasExeName {slave} {
    return ""
}





















































proc ::safe::Setup {} {
    ####
    #
    # Setup the arguments parsing
    #
    ####

    # Share the descriptions
    set temp [::tcl::OptKeyRegister {
	{-accessPath -list {} "access path for the slave"}
	{-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 (slave is optional)
    ::tcl::OptKeyRegister {
	{?slave? -name {} "name of the slave (optional)"}
    } ::safe::interpCreate

    # adding the flags sub programs to the command program (relying on Opt's
    # internal implementation details)
    lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp)

    # init and configure (slave is needed)
    ::tcl::OptKeyRegister {
	{slave -name {} "name of the slave"}
    } ::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







|



>
>
>
>














<
<
<
<
<
<
<

|










|



|
|

|



>
>
>
|
|
>
>
>
>
>
>
>
|
>
|




>
|
>




|
<

>
>
>
>
|
|

|


|
|





>
>
>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>

|


|






|





>
>
>
>
>
>
>
|

>
>
|



|

|









|





|








|








|






|

|



|

|

|



|
>
>
>

|

|
|



|

|









|


|


|



|







|



|






|








|










|



|








|

|





|

|





|

>
>
>
>
>
>
>
|





|



|
|











|





|
|










|








|

|





|

|
|





|


|




|


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>










|







|

|






|

|







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
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128

namespace eval ::safe {
    # internal variables

    # Log command, set via 'setLogCmd'. Logging is disabled when empty.
    variable Log {}

    # The package maintains a state array per slave interp under its
    # control. The name of this array is S<interp-name>. This array is
    # brought into scope where needed, using 'namespace upvar'. The S
    # prefix is used to avoid that a slave interp called "Log" smashes
    # the "Log" variable.
    #
    # The array's elements are:
    #
    # access_path       : List of paths accessible to the slave.
    # access_path,norm  : Ditto, in normalized form.
    # access_path,slave : Ditto, as the path tokens as seen by the slave.
    # access_path,map   : dict ( token -> path )
    # access_path,remap : dict ( path -> token )
    # tm_path_slave     : List of TM root directories, as tokens seen by the slave.
    # staticsok         : Value of option -statics
    # nestedok          : Value of option -nested
    # cleanupHook       : Value of option -deleteHook
}

::safe::Setup







|


|




|

|


|






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
643
644
645
646
647
648
649
650
	    }
	}
	return $valid
    }

    proc IsVerbose {level} {
	variable Option
	return [expr {[lsearch -exact $Option(-verbose) $level] != -1}]
    }

    # 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







|







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
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 == -1} {
	DebugDo 1 {
	    Warn "removeFile removing \"$fullName\":\n  not created by makeFile"
	}
    } else {
	set filesMade [lreplace $filesMade $idx $idx]
    }
    if {![file isfile $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
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 == -1} {
	DebugDo 1 {
	    Warn "removeDirectory removing \"$fullName\":\n  not created\
		    by makeDirectory"
	}
    }
    if {![file isdirectory $fullName]} {
	DebugDo 1 {







|







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
215
216
217
218


219

220
221
222
223
224
225
226
	    }
	    set currentsearchpath [file join $path $pkgroot]
	    if {![interp issafe] && ![file exists $currentsearchpath]} {
		continue
	    }
	    set strip [llength [file split $path]]

	    # We can't use glob in safe interps, so enclose the following in a
	    # catch statement, where we get the module files out of the
	    # subdirectories. In other words, Tcl Modules are not-functional
	    # in such an interpreter. This is the same as for the command


	    # "tclPkgUnknown", i.e. the search for regular packages.


	    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] ::]







<
|
<
|
>
>
|
>







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
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.2\nnamespace import tcltest::*\nconfigure -testdir [file normalize {' \"${TCL_SRCROOT}\" '/tests}]\nconfigure -tmpdir [file normalize {' \"${DERIVED_FILE_DIR}\" '}]\nconfigure -verbose [concat [configure -verbose] line]\nrunAllTests\n' | \"${TEST_RIG}\"; TEST_RIG_RESULT=$?\n[ ${TEST_RIG_RESULT} -ne 0 ] && echo \"tcltest:0: error: tcltest exited abnormally with code ${TEST_RIG_RESULT}.\"\nexit ${TEST_RIG_RESULT}\nfi";
			showEnvVarsInLog = 0;
		};
		F97AF02F0B665DA900310EA2 /* Build Tcl */ = {
			isa = PBXShellScriptBuildPhase;
			buildActionMask = 2147483647;
			files = (
			);







|







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
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.2\nnamespace import tcltest::*\nconfigure -testdir [file normalize {' \"${TCL_SRCROOT}\" '/tests}]\nconfigure -tmpdir [file normalize {' \"${DERIVED_FILE_DIR}\" '}]\nconfigure -verbose [concat [configure -verbose] line]\nrunAllTests\n' | \"${TEST_RIG}\"; TEST_RIG_RESULT=$?\n[ ${TEST_RIG_RESULT} -ne 0 ] && echo \"tcltest:0: error: tcltest exited abnormally with code ${TEST_RIG_RESULT}.\"\nexit ${TEST_RIG_RESULT}\nfi";
			showEnvVarsInLog = 0;
		};
		F97AF02F0B665DA900310EA2 /* Build Tcl */ = {
			isa = PBXShellScriptBuildPhase;
			buildActionMask = 2147483647;
			files = (
			);







|







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
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 master 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







|







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
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
    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}







|







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
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.test" 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.



|







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
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
    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







|







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
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
    namespace import -force ::tcltest::*
}
catch {unset x}

test appendComp-1.1 {append command} -setup {
    unset -nocomplain x
} -body {







|







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
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 slave
} -body {
    slave eval {
	proc foo {} {
	    proc append args {}
	    append
	}
	foo
    }
} -cleanup {
    interp delete slave
} -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.








|

|







|







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
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.2
    namespace import -force ::tcltest::*
}

if {[info commands ::apply] eq {}} {
    return
}








|







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

14
15

16
17
18
19
20
21
22
# 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.


package require tcltest 2
namespace import ::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]]













>
|
|
>







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testasync [llength [info commands testasync]]







|







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
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
    namespace import -force ::tcltest::*
}

makeFile {# Test file for:
#   auto_mkindex
#
# This file provides example cases for testing the Tcl autoloading facility.












|







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
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 slave
} -body {
    auto_mkindex . autoMkindex.tcl
    slave 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 slave
} -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







|


|









|







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
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 slave
} -body {
    auto_mkindex . pkg/magicchar2.tcl
    # Make a slave interp to test the autoloading
    slave eval {lappend auto_path [pwd]}
    slave eval {catch {{[magic mojo proc]}}}
} -cleanup {
    interp delete slave
    removeFile [file join pkg magicchar2.tcl]
    removeDirectory pkg
} -result 0

# Clean up.

unset 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

18
19

20
21
22
23
24
25
26
#
# 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.


package require tcltest 2
namespace import ::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]]







>
|
|
>







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
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
	testevalex {set ::context $x} global
    }
    namespace delete ns
    set ::context
} {global}

test basic-50.1 {[586e71dce4] EvalObjv level #0 exception handling} -setup {
    interp create slave
    interp alias {} foo slave return
} -body {
    list [catch foo m] $m
} -cleanup {
    unset -nocomplain m
    interp delete slave
} -result {0 {}}

# Clean up after expand tests
unset noComp l1 l2 constraints
rename l3 {}
rename run {}








|
|




|







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
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
    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]













|







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
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
    namespace import -force ::tcltest::*
}

#
# Note: The tests for the chan methods "create" and "postevent"
# currently reside in the file "ioCmd.test".
#










|







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
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 != -1 || $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







|







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
17

18
19
20



21

22
23
24
25
26
27
28
# 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

}

namespace eval ::tcl::test::io {



    namespace import ::tcltest::*


    variable umaskValue
    variable path
    variable f
    variable i
    variable n
    variable v







|
>



>
>
>
|
>







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
5723
5724
5725
5726
5727
5728
5729
5730
    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} {
    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 {}







|







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
6386
6387

6388
6389
6390
6391
6392
6393
6394

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
    }]
    variable z not_called
    update

    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]







>
>
>




|
|
>







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
6477
6478
6479
6480
6481
6482
6483
6484
    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} -body {
    proc notcalled {f} {
	variable z
	lappend z "notcalled was called!! $f"
    }
    proc del {f} {
	variable u
	variable z







|







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
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
    namespace import -force ::tcltest::*
}

if {[testConstraint win]} {
    if {[catch {
	    ::tcltest::loadTestedCommands
	    package require registry







|







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
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.1
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testchmod       [llength [info commands testchmod]]













|







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
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 slave
    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]]







|







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
12
13
14

15
16
17
18
19
20
21
# 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
    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]]











|


>







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

16
17

18
19
20
21
22
23
24
# 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.


package require tcltest 2
namespace import ::tcltest::*


::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testcmdinfo  [llength [info commands testcmdinfo]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]








>
|
|
>







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

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 {[catch {package require tcltest 2.1}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
    return
}

namespace eval ::tcl::test::cmdMZ {
    namespace import ::tcltest::cleanupTests
    namespace import ::tcltest::customMatch
    namespace import ::tcltest::makeFile
    namespace import ::tcltest::removeFile













>
|
|
<







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
16
17
18

19
20
21
22
23
24
25
# 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
    namespace import -force ::tcltest::*
}


::tcltest::loadTestedCommands

# Big test for correct ordering of data in [expr]

proc testIEEE {} {
    variable ieeeValues







|


>







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands

# Constrain memory leak tests
testConstraint memory [llength [info commands memory]]











|







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
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 slave
	slave eval expr 1+2+3+4+5+6+7+8+9+10+11+12+13
	interp delete slave
	set tmp $end
	set end [getbytes]
    }
    set leakedBytes [expr {$end - $tmp}]
} -cleanup {
    unset end i tmp
    rename getbytes {}







|
|
|







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

14
15


16
17
18
19
20
21
22
# 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.


package require tcltest 2
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]]













>
|
|
>
>







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
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
    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} {







|







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
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
    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} {







|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testnrelevels [llength [info commands testnrelevels]]












|







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
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 slave
    slave eval {
	coroutine demo apply {{} { while {1} yield }}
	demo
	tcl::unsupported::inject demo set ::result inject-executed
    }
    interp delete slave
} -result {}
test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body {
    interp create slave
    slave eval {
	coroutine demo apply {{} { while {1} yield }}
	demo
	tcl::unsupported::inject demo set ::result inject-executed
    }
    slave eval demo
    set result [slave eval {set ::result}]

    interp delete slave
    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 {







|
|




|


|
|




|
|

|







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

14
15

16
17
18
19
20
21
22
# 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.


package require tcltest 2
namespace import ::tcltest::*


::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testdcall [llength [info commands testdcall]]

test dcall-1.1 {deletion callbacks} testdcall {













>
|
|
>







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testdstring [llength [info commands testdstring]]







|







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

11



12
13
14
15
16
17
18
19
20
21
22
23
24
# 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.


package require tcltest 2




namespace eval ::tcl::test::encoding {
    variable x

namespace import -force ::tcltest::*

catch {
    ::tcltest::loadTestedCommands
    package require -exact Tcltest [info patchlevel]
}

proc toutf {args} {
    variable x










>
|
>
>
>




<
<







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
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
    namespace import -force ::tcltest::*
}

loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
package require tcltests








|







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
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 master should unset child} -setup {
    setup1
    interp create i
} -body {
    # Variables deleted in a master 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







|



|







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
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
    namespace import -force ::tcltest::*
}

testConstraint memory [llength [info commands memory]]
customMatch pairwise {apply {{a b} {
    string equal [lindex $b 0] [lindex $b 1]
}}}







|







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
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
    namespace import -force ::tcltest::*
}

test eval-1.1 {single argument} {
    eval {format 22}
} 22
test eval-1.2 {multiple arguments} {







|







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
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
namespace import -force ::tcltest::*

catch {
    ::tcltest::loadTestedCommands
    package require -exact Tcltest [info patchlevel]
    set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
}











|







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

17
18

19
20
21
22
23
24
25
#
# 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.


package require tcltest 2
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.







>
|
|
>







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

catch {namespace delete {*}[namespace children :: test_ns_*]}







|







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
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 slave
} -body {
    set script { llength {} }
    slave eval {proc llength args {return AHA!}}
    set result {}
    lappend result [if 1 $script]
    lappend result [slave eval $script]
} -cleanup {
    interp delete slave
} -result {0 AHA!}
test execute-6.10 {TclCompEvalObj: bytecode interp validation} -body {
    set script { llength {} }
    interp create slave
    set result {}
    lappend result [slave eval $script]
    interp delete slave
    interp create slave
    lappend result [slave eval $script]
} -cleanup {
    catch {interp delete slave}
} -result {0 0}
test execute-6.11 {Tcl_ExprObj: exprcode interp validation} -setup {
    interp create slave
} -constraints testexprlongobj -body {
    set e { [llength {}]+1 }
    set result {}
    load {} Tcltest slave
    interp alias {} e slave testexprlongobj
    lappend result [e $e]
    interp delete slave
    interp create slave
    load {} Tcltest slave
    interp alias {} e slave testexprlongobj
    lappend result [e $e]
} -cleanup {
    interp delete slave
} -result {{This is a result: 1} {This is a result: 1}}
test execute-6.12 {Tcl_ExprObj: exprcode interp validation} -setup {
    interp create slave
} -body {
    set e { [llength {}]+1 }
    set result {}
    interp alias {} e slave expr
    lappend result [e $e]
    interp delete slave
    interp create slave
    interp alias {} e slave expr
    lappend result [e $e]
} -cleanup {
    interp delete slave
} -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







|


|


|

|



|

|
|
|
|

|


|



|
|

|
|
|
|


|


|



|

|
|
|


|







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
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 slave
} -body {
    set e { [llength {}]+1 }
    interp alias {} e slave expr
    slave eval {proc llength args {return 1}}
    set result {}
    lappend result [expr $e]
    lappend result [e $e]
} -cleanup {
    interp delete slave
} -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]







|


|
|




|







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
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 slave
    slave eval {
	package require tcltest
	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 {
    slave eval {
	lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
    }
    slave eval {
	set i 0; while {[incr i] < 3} {
	    lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
	}
    }
    slave eval {
	set i 0; while {[incr i] < 3} {
	    lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
	}
    }
    slave eval {
	catch {
	    lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C;
	}
    }
    slave eval {set res}
} -cleanup {
    interp delete slave
} -result [lrepeat 4 A B]
test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), exception case} -setup {
    interp create slave
    slave eval {
	package require tcltest
	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 {
	slave eval {
	   lappend res A; testbumpinterpepoch; lappend res B; return -code error test; lappend res C;
	}
    } e] $e
    lappend res [catch {
	slave eval {
	   lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C;
	}
    } e] $e
    lappend res [catch {
	slave eval {
	   lappend res A; testbumpinterpepoch; lappend res B; return -code return test; lappend res C;
	}
    } e] $e
    lappend res [catch {
	slave eval {
	   lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
	}
    } e] $e
    list $res [slave eval {set res}]
} -cleanup {
    interp delete slave
} -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 slave
} -body {
    # If [Bug 2802881] is not fixed, this will segfault
    slave eval {
	trace add variable ::errorInfo write {expr {$foo} ;#}
	proc demo {} {a {}{}}
	demo
    }
} -cleanup {
    interp delete slave
} -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
	}
    }







|
|
|







|


|




|




|




|

|


|
|
|









|




|




|




|



|

|




















|


|





|







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
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 slave
} -body {
    slave 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 slave
} -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







|

|









|







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

16
17

18
19
20
21
22
23
24
# 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.


package require tcltest 2.1
namespace import ::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]]







>
|
|
>







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
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.1
    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.













|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

cd [temporaryDirectory]













|







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
14
15
16

17
18
19
20
21
22
23
# 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
    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













|


>







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
12
13



14

15
16
17
18
19
20
21
# 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.

package require tcltest 2
namespace eval ::tcl::test::fileSystem {



    namespace import ::tcltest::*


    catch {
	file delete -force link.file
	file delete -force dir.link
	file delete -force [file join dir.dir linkinside.file]
    }












<

>
>
>
|
>







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


10
11

12
13
14
15
16
17
18
#!  /usr/bin/env tclsh

# Copyright (c) 2019 Poor Yorick

if {[string equal $::tcl_platform(os) "Windows NT"]} {
    return
}

namespace eval ::tcl::test::fileSystemEncoding {


    package require tcltest 2
    namespace import ::tcltest::*


    variable fname1 \u767b\u9e1b\u9d72\u6a13

    proc autopath {} {
	global auto_path
	set scriptpath [info script]
	set scriptpathnorm [file dirname [file normalize $scriptpath/...]]









>
>
|
|
>







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
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
    namespace import -force ::tcltest::*
}

# Check "for" and its use of continue and break.

catch {unset a i}
test for-old-1.1 {for tests} {







|







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
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
    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}












|







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
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
    namespace import -force ::tcltest::*
}

catch {unset a}
catch {unset x}

# Basic "foreach" operation.













|







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
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
    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}]













|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testgetint [llength [info commands testgetint]]













|







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
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
    namespace import -force ::tcltest::*
}

# The history command might be autoloaded...
if {[catch {history}]} {
    testConstraint history 0
} else {







|







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

14
15

16
17
18
19
20
21
22
23
24
25
26
27
28
29
# 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.


package require tcltest 2
namespace import -force ::tcltest::*


if {[catch {package require http 2} version]} {
    if {[info exists http2]} {
	catch {puts "Cannot load http 2.* package"}
	return
    } else {
	catch {puts "Running http 2.* tests in slave interp"}
	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
    }













>
|
|
>






|







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

10
11

12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
# 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.


package require tcltest 2
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] != -1} {
            #puts stderr "read '$line'"
            set httpd_output $line
        }
        if {[eof $chan]} {
            puts stderr "eof from httpd"
            fileevent $chan readable {}
            close $chan









>
|
|
>








|







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

11
12

13
14
15
16
17
18
19
# 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.


package require tcltest 2
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]











>
|
|
>







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
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] != -1} {
        ::httpTest::LogRecord $txt
        ::httpTest::Puts $txt
    } elseif {$::httpTest::testOptions(-verbose) > 1} {
        ::httpTest::Puts $txt
    }
    return
}







|







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
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 == -1} {
        # 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]
    }







|







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
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 == -1 || $myEnd == -1)} {
            set res "Cannot find positions of transaction $i"
	    append msg $res \n
	    Puts $res
        }

	set overlaps {}
	for {set j $myStart} {$j <= $myEnd} {incr j} {







|







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
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 == -1} {
        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 == -1} {
	    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 == -1} {
	    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 {







|
















|








|







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

12
13

14
15
16
17
18
19
20
# 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.


package require tcltest 2
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]}]
}}]











>
|
|
>







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
189
190
191
192
193
194




195
196
197
198
199
200
201
		}
	    }
            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]]
        }
        if {$close} {
            Puts $chan "connection: close"
        }
	Puts $chan "x-requested-encodings: [dict get? $meta accept-encoding]"
        if {$encoding eq "identity"} {
            Puts $chan "content-length: [string length $data]"




        } else {
            Puts $chan "content-encoding: $encoding"
        }
        if {$transfer eq "chunked"} {
            Puts $chan "transfer-encoding: chunked"
        }
        puts $chan ""







>



>




>
>
>









|



|

>
>
>
>







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
231
232
233
234
235
236
237
238

proc Accept {chan addr port} {
    coroutine client$chan Service $chan $addr $port
    return
}

proc Control {chan} {
    if {[gets $chan line] != -1} {
        if {[string trim $line] eq "quit"} {
            set ::forever 1
        }
    }
    if {[eof $chan]} {
        chan event $chan readable {}
    }







|







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
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
    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







|







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
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
    namespace import -force ::tcltest::*
}

# Basic "if" operation.

catch {unset a}
test if-1.1 {TclCompileIfCmd: missing if/elseif test} -body {













|







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
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
    namespace import -force ::tcltest::*
}

catch {unset x}

test incr-old-1.1 {basic incr operation} {
    set x 23







|







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
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
    namespace import -force ::tcltest::*
}

unset -nocomplain x i
proc readonly varName {
    upvar 1 $varName var
    trace add variable var write \













|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testindexobj [llength [info commands testindexobj]]











|







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
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
    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",







|







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
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.3.4
    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 {













|







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
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.1
    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 slaves] {
  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
} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
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 slaves foo bar zop
} -result {wrong # args: should be "interp slaves ?path?"}
test interp-1.7 {options for interp command} -returnCodes error -body {
    interp hello
} -result {bad option "hello": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
test interp-1.8 {options for interp command} -returnCodes error -body {
    interp -froboz
} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
test interp-1.9 {options for interp command} -returnCodes error -body {
    interp -froboz -safe
} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
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













|










|









|













|
|


|


|


|







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
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 slaves] {
    interp delete $i
}

# Part 2: Testing "interp slaves" and "interp exists"
test interp-3.1 {testing interp exists and interp slaves} {
    interp slaves
} ""
test interp-3.2 {testing interp exists and interp slaves} {
    interp create a
    interp exists a
} 1
test interp-3.3 {testing interp exists and interp slaves} {
    interp exists nonexistent
} 0
test interp-3.4 {testing interp exists and interp slaves} -body {
    interp slaves a b c
} -returnCodes error -result {wrong # args: should be "interp slaves ?path?"}
test interp-3.5 {testing interp exists and interp slaves} -body {
    interp exists a b c
} -returnCodes error -result {wrong # args: should be "interp exists ?path?"}
test interp-3.6 {testing interp exists and interp slaves} {
    interp exists
} 1
test interp-3.7 {testing interp exists and interp slaves} -setup {
    catch {interp create a}
} -body {
    interp slaves
} -result a
test interp-3.8 {testing interp exists and interp slaves} -body {
    interp slaves a b c
} -returnCodes error -result {wrong # args: should be "interp slaves ?path?"}
test interp-3.9 {testing interp exists and interp slaves} -setup {
    catch {interp create a}
} -body {
    interp create {a a2} -safe
    expr {"a2" in [interp slaves a]}
} -result 1
test interp-3.10 {testing interp exists and interp slaves} -setup {
    catch {interp create a}
    catch {interp create {a a2}}
} -body {
    interp exists {a a2}
} -result 1

# Part 3: Testing "interp delete"







|



|
|
|

|



|


|
|
|
|


|


|


|

|
|
|
|



|

|







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
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 slaves 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 slaves] {
    interp delete $i
}

# Part 4: Consistency checking - all nondeleted interpreters should be
# there:
test interp-5.1 {testing consistency} {
    interp slaves
} ""
test interp-5.2 {testing consistency} {
    interp exists a
} 0
test interp-5.3 {testing consistency} {
    interp exists nonexistent
} 0







|
















|






|







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
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 MASTER INTERPRETER:
proc in_master {args} {
     return [list seen in master: $args]
}

# Part 6: Testing basic alias creation
test interp-7.1 {testing basic alias creation} {
    a alias foo in_master
} foo
catch {a alias foo in_master}
test interp-7.2 {testing basic alias creation} {
    a alias bar in_master a1 a2 a3
} bar
catch {a alias bar in_master a1 a2 a3}
# Test 6.3 has been deleted.
test interp-7.3 {testing basic alias creation} {
    a alias foo
} in_master
test interp-7.4 {testing basic alias creation} {
    a alias bar
} {in_master 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_master
    a eval foo s1 s2 s3
} {seen in master: {s1 s2 s3}}
test interp-8.2 {testing basic alias invocation} {
    catch {interp create a}
    a alias bar in_master a1 a2 a3
    a eval bar s1 s2 s3
} {seen in master: {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-master
    list [catch {a eval zop} msg] $msg
} {1 {invalid command name "nonexistent-command-in-master"}}
test interp-9.2 {testing aliases for non-existent targets} {
    catch {interp create a}
    a alias zop nonexistent-command-in-master
    proc nonexistent-command-in-master {} {return i_exist!}
    a 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 {}







|
|
|




|

|

|

|



|


|










|

|


|

|








|

|


|
|







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
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-master] != ""} {
    rename nonexistent-command-in-master {}
}

# Part 9: Aliasing between interpreters
test interp-10.1 {testing aliasing between interpreters} {
    catch {interp delete a}
    catch {interp delete b}
    interp create a







|
|







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
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_master b1 b2 b3
    a eval a_command m1 m2 m3
} {seen in master: {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 {}}







|

|







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
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 master} {
    # 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}







|







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
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 slave interpreter.
# If there are bugs in the implementation these tests are likely to expose
# the bugs as a core dump.
#

test interp-18.1 {testing Tcl_DeleteInterp vs slaves} testinterpdelete {
    list [catch {testinterpdelete} msg] $msg
} {1 {wrong # args: should be "testinterpdelete path"}}
test interp-18.2 {testing Tcl_DeleteInterp vs slaves} testinterpdelete {
    catch {interp delete a}
    interp create a
    testinterpdelete a
} ""
test interp-18.3 {testing Tcl_DeleteInterp vs slaves} testinterpdelete {
    catch {interp delete a}
    interp create a
    interp create {a b}
    testinterpdelete {a b}
} ""
test interp-18.4 {testing Tcl_DeleteInterp vs slaves} testinterpdelete {
    catch {interp delete a}
    interp create a
    interp create {a b}
    testinterpdelete a
} ""
test interp-18.5 {testing Tcl_DeleteInterp vs slaves} 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 slaves} 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 {}}







|




|


|




|





|





|







|







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
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 slave
} -body {
    slave invokehidden -namespace ::foo source $script
    slave eval {set ::foo::x}
} -cleanup {
    interp delete slave
    removeFile script
} -result ::foo
test interp-20.50 {Bug 2486550} -setup {
    interp create slave
} -body {
    slave hide coroutine
    slave invokehidden coroutine
} -cleanup {
    interp delete slave
} -returnCodes error -match glob -result *
test interp-20.50.1 {Bug 2486550} -setup {
    interp create slave
} -body {
    slave hide coroutine
    catch {slave invokehidden coroutine} m o
    dict get $o -errorinfo
} -cleanup {
    unset -nocomplain m 0
    interp delete slave
} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?"
    while executing
"coroutine"
    invoked from within
"slave invokehidden coroutine"}

test interp-21.1 {interp hidden} {
    interp hidden {}
} ""
test interp-21.2 {interp hidden} {
    interp hidden
} ""







|

|
|

|



|

|
|

|


|

|
|



|




|







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
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 slave interp's context to the master, even though the
    # slave 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]
    }







|
|







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
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
    # slave interp's context to the master, even though the slave 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
    }







|







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
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
    # master 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







|







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
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-master
    namespace eval foo {
	variable v foo-master
	proc bar {interp args} {
	    variable v
	    list "master bar called ($v) ([namespace current]) ($args)"\
		[interp invokehidden $interp foo::bar $args]
	}
    }
    interp eval $i {
	namespace eval foo {
	    namespace export *
	    variable v foo-slave
	    proc bar {args} {
		variable v
		return "slave 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-slave
	namespace eval test {
	    variable v foo-test
	    namespace import ::foo::*
	    bar test2
	}
    }]]
} -cleanup {
    namespace delete foo
    interp delete $i
} -result {{slave bar called (foo-slave) (::foo) (test1)} {master bar called (foo-master) (::foo) (test2)} {slave bar called (foo-slave) (::foo) (test2)}}
test interp-27.7 {interp hidden & aliases & imports & namespaces} -setup {
    set i [interp create]
} -constraints knownBug -body {
    set v root-master
    namespace eval mfoo {
	variable v foo-master
	proc bar {interp args} {
	    variable v
	    list "master bar called ($v) ([namespace current]) ($args)"\
		[interp invokehidden $interp test::bar $args]
	}
    }
    interp eval $i {
	namespace eval foo {
	    namespace export *
	    variable v foo-slave
	    proc bar {args} {
		variable v
		return "slave bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)"
	    }
	}
	set v root-slave
	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 {{slave bar called (foo-slave) (bar test1) (::tcltest) (::foo) (test1)} {master bar called (foo-master) (::mfoo) (test2)} {slave bar called (foo-slave) (test::bar test2) (::) (::foo) (test2)}}
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 slave's namespace ?} -setup {
    set i [interp create -safe]
    proc master {interp args} {interp hide $interp list}
} -body {
    $i alias master master $i
    set r [interp eval $i {
        namespace eval foo {
	    proc list {args} {
		return "dummy foo::list"
	    }
	    master
	}
	info commands list
    }]
} -cleanup {
    rename master {}
    interp delete $i
} -result {}
test interp-28.2 {master'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]]







|

|


|






|


|







|









|



|

|


|






|


|


|












|











|

|

|





|




|


|







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
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 {slave recursionlimit argument checking} {
    interp create moo
    set result [catch {moo recursionlimit foo bar} msg]
    interp delete moo
    list $result $msg
} {1 {wrong # args: should be "moo recursionlimit ?newlimit?"}}
test interp-29.1.9 {slave recursionlimit argument checking} {
    interp create moo
    set result [catch {moo recursionlimit foo} msg]
    interp delete moo
    list $result $msg
} {1 {expected integer but got "foo"}}
test interp-29.1.10 {slave recursionlimit argument checking} {
    interp create moo
    set result [catch {moo recursionlimit 0} msg]
    interp delete moo
    list $result $msg
} {1 {recursion limit must be > 0}}
test interp-29.1.11 {slave recursionlimit argument checking} {
    interp create moo
    set result [catch {moo recursionlimit -1} msg]
    interp delete moo
    list $result $msg
} {1 {recursion limit must be > 0}}
test interp-29.1.12 {slave recursionlimit argument checking} {
    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 {}







|





|





|





|





|







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
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 slave
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2
	        eval {		# 3
		    eval {	# 4
		        eval {	# 5
			     interp recursionlimit {} 5
			     set x ok
			}
		    }
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {1 {falling back due to new recursion limit}}
test interp-29.3.5 {recursion limit error reporting} {
    interp create slave
    set r1 [slave eval {
        catch {			# nesting level 1
	    eval {		# 2
	        eval {		# 3
		    eval {	# 4
		        eval {	# 5
			    interp recursionlimit {} 4
			    set x ok
			}
		    }
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {1 {falling back due to new recursion limit}}
test interp-29.3.6 {recursion limit error reporting} {
    interp create slave
    set r1 [slave eval {
        catch {			# nesting level 1
	    eval {		# 2
	        eval {		# 3
		    eval {	# 4
		        eval {	# 5
			    interp recursionlimit {} 6
			    set x ok
			}
		    }
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    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 slave
    after 0 {interp recursionlimit slave 5}
    set r1 [slave eval {










































































































        catch { 		# nesting level 1
	    eval {		# 2
	        eval {		# 3
		    eval {	# 4
		        eval {	# 5
			    update
			    set x ok
			}
		    }
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {0 ok}
test interp-29.3.7b {recursion limit error reporting} {
    interp create slave
    after 0 {interp recursionlimit slave 5}
    set r1 [slave eval {










































        catch { 		# nesting level 1
	    eval {		# 2
	        eval {		# 3
		    eval {	# 4
			update
		        eval {	# 5
			    set x ok
			}
		    }
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2





















} {0 ok}
test interp-29.3.7c {recursion limit error reporting} {
    interp create slave
    after 0 {interp recursionlimit slave 5}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2
	        eval {		# 3
		    eval {	# 4
		        eval {	# 5
			    update
			    set set set
			    $set x ok
			}
		    }
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.8a {recursion limit error reporting} {
    interp create slave
    after 0 {interp recursionlimit slave 4}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2
	        eval {		# 3
		    eval {	# 4
		        eval {	# 5
			    update
			    set x ok
			}
		    }
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {0 ok}
test interp-29.3.8b {recursion limit error reporting} {
    interp create slave
    after 0 {interp recursionlimit slave 4}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2
	        eval {		# 3
		    eval {	# 4
			update
		        eval {	# 5
			    set x ok
			}
		    }
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.9a {recursion limit error reporting} {
    interp create slave
    after 0 {interp recursionlimit slave 6}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2
	        eval {		# 3
		    eval {	# 4
		        eval {	# 5
			    update
			    set x ok
			}
		    }
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {0 ok}
test interp-29.3.9b {recursion limit error reporting} {
    interp create slave
    after 0 {interp recursionlimit slave 6}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2
	        eval {		# 3
		    eval {	# 4
		        eval {	# 5
			    set set set
			    $set x ok
			}
		    }
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {0 ok}
test interp-29.3.10a {recursion limit error reporting} {
    interp create slave
    after 0 {slave recursionlimit 4}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2
	        eval {		# 3
		    eval {	# 4
		        eval {	# 5
			     update
			     set x ok
			}
		    }
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {0 ok}
test interp-29.3.10b {recursion limit error reporting} {
    interp create slave
    after 0 {slave recursionlimit 4}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2
	        eval {		# 3
		    eval {	# 4
			update
		        eval {	# 5
			    set x ok
			}
		    }
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.11a {recursion limit error reporting} {
    interp create slave
    after 0 {slave recursionlimit 5}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2
	        eval {		# 3
		    eval {	# 4
		        eval {	# 5
			    update
			    set x ok
			}
		    }
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {0 ok}
test interp-29.3.11b {recursion limit error reporting} {
    interp create slave
    after 0 {slave recursionlimit 5}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2
	        eval {		# 3
		    eval {	# 4
		        eval {	# 5
			    update
			    set set set
			    $set x ok
			}
		    }
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.12a {recursion limit error reporting} {
    interp create slave
    after 0 {slave recursionlimit 6}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2
	        eval {		# 3
		    eval {	# 4
		        eval {	# 5
			    update
			    set x ok
			}
		    }
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {0 ok}
test interp-29.3.12b {recursion limit error reporting} {
    interp create slave
    after 0 {slave recursionlimit 6}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2
	        eval {		# 3
		    eval {	# 4
		        eval {	# 5
			    update
			    set set set
			    $set x ok
			}
		    }
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    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







|
|













|
|



|
|













|
|



|
|













|
|







|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>













|
|


|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>













|
|

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|
|
|
|














|
|


|
|
|
|













|
|


|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







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
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 slave recursion limit affect master?} {
    set before [interp recursionlimit {}]
    set i [interp create]
    interp recursionlimit $i 20000
    set after [interp recursionlimit {}]
    set slavelimit [interp recursionlimit $i]
    interp delete $i
    list [expr {$before == $after}] $slavelimit
} {1 20000}
test interp-29.5.2 {does slave recursion limit affect master?} {
    set before [interp recursionlimit {}]
    set i [interp create]
    interp recursionlimit $i 20000
    set after [interp recursionlimit {}]
    set slavelimit [$i recursionlimit]
    interp delete $i
    list [expr {$before == $after}] $slavelimit
} {1 20000}
test interp-29.5.3 {does slave recursion limit affect master?} {
    set before [interp recursionlimit {}]
    set i [interp create]
    $i recursionlimit 20000
    set after [interp recursionlimit {}]
    set slavelimit [interp recursionlimit $i]
    interp delete $i
    list [expr {$before == $after}] $slavelimit
} {1 20000}
test interp-29.5.4 {does slave recursion limit affect master?} {
    set before [interp recursionlimit {}]
    set i [interp create]
    $i recursionlimit 20000
    set after [interp recursionlimit {}]
    set slavelimit [$i recursionlimit]
    interp delete $i
    list [expr {$before == $after}] $slavelimit
} {1 20000}
test interp-29.6.1 {safe interpreter recursion limit} {
    interp create slave -safe
    set n [interp recursionlimit slave]
    interp delete slave
    set n
} 1000
test interp-29.6.2 {safe interpreter recursion limit} {
    interp create slave -safe
    set n [slave recursionlimit]
    interp delete slave
    set n
} 1000
test interp-29.6.3 {safe interpreter recursion limit} {
    interp create slave -safe
    set n1 [interp recursionlimit slave 42]
    set n2 [interp recursionlimit slave]
    interp delete slave
    list $n1 $n2
} {42 42}
test interp-29.6.4 {safe interpreter recursion limit} {
    interp create slave -safe
    set n1 [slave recursionlimit 42]
    set n2 [interp recursionlimit slave]
    interp delete slave
    list $n1 $n2
} {42 42}
test interp-29.6.5 {safe interpreter recursion limit} {
    interp create slave -safe
    set n1 [interp recursionlimit slave 42]
    set n2 [slave recursionlimit]
    interp delete slave
    list $n1 $n2
} {42 42}
test interp-29.6.6 {safe interpreter recursion limit} {
    interp create slave -safe
    set n1 [slave recursionlimit 42]
    set n2 [slave recursionlimit]
    interp delete slave
    list $n1 $n2
} {42 42}
test interp-29.6.7 {safe interpreter recursion limit} {
    interp create slave -safe
    set n1 [slave recursionlimit 42]
    set n2 [slave recursionlimit]
    interp delete slave
    list $n1 $n2
} {42 42}
test interp-29.6.8 {safe interpreter recursion limit} {
    interp create slave -safe
    set n [catch {slave eval {interp recursionlimit {} 42}} msg]
    interp delete slave
    list $n $msg
} {1 {permission denied: safe interpreters cannot change recursion limit}}
test interp-29.6.9 {safe interpreter recursion limit} {
    interp create slave -safe
    set result [
	slave eval {
	    interp create slave2 -safe
	    set n [catch {
	        interp recursionlimit slave2 42
            } msg]
            list $n $msg
        }
    ]
    interp delete slave
    set result
} {1 {permission denied: safe interpreters cannot change recursion limit}}
test interp-29.6.10 {safe interpreter recursion limit} {
    interp create slave -safe
    set result [
        slave eval {
	    interp create slave2 -safe
	    set n [catch {
	        slave2 recursionlimit 42
            } msg]
            list $n $msg
        }
    ]
    interp delete slave
    set result
} {1 {permission denied: safe interpreters cannot change recursion limit}}


#    # Deep recursion (into interps when the regular one fails):
#    # still crashes...
#    proc p {} {







|




|

|

|




|

|

|




|

|

|




|

|


|
|
|



|
|
|



|
|
|
|



|
|
|
|



|
|
|
|



|
|
|
|



|
|
|
|



|
|
|



|

|
|

|




|



|

|
|

|




|







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
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 slave
} -body {
    slave bgerror x y
} -cleanup {
    interp delete slave
} -returnCodes error -result {wrong # args: should be "slave bgerror ?cmdPrefix?"}
test interp-36.4 {SlaveBgerror syntax} -setup {
    interp create slave
} -body {
    slave bgerror \{
} -cleanup {
    interp delete slave
} -returnCodes error -result {cmdPrefix must be list of length >= 1}
test interp-36.5 {SlaveBgerror syntax} -setup {
    interp create slave
} -body {
    slave bgerror {}
} -cleanup {
    interp delete slave
} -returnCodes error -result {cmdPrefix must be list of length >= 1}
test interp-36.6 {SlaveBgerror returns handler} -setup {
    interp create slave
} -body {
    slave bgerror {foo bar soom}
} -cleanup {
    interp delete slave
} -result {foo bar soom}
test interp-36.7 {SlaveBgerror sets error handler of slave [1999035]} -setup {
    interp create slave
    slave alias handler handler
    slave bgerror handler
    variable result {untouched}
    proc handler {args} {
        variable result
        set result [lindex $args 0]
    }
} -body {
    slave 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 slave
} -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 {







|

|

|
|
|
|

|

|

|
|

|

|

|
|

|

|

|
|
|
|






|









|







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
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 slaves] {
    interp delete $i
}
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:







|









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
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
}

namespace eval ::tcl::test::io {
    namespace import ::tcltest::*

    variable umaskValue
    variable path







|







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
6090
6091
6092
6093
6094
6095
6096
6097
    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} {
    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 {}







|







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
6898
6899
6900
6901
6902
6903
6904
6905
    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} -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"







|







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
8761
8762
8763
8764
8765
8766
8767
8768
8769
8770
8771
8772
8773
8774
8775
8776
8777
    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 slave
} -constraints testobj -body {
    teststringobj set 1 [string range $rfd 0 end]
    read [teststringobj get 1]
    testobj duplicate 1 2
    interp transfer {} $rfd slave
    catch {read [teststringobj get 1]}
    read [teststringobj get 2]
} -cleanup {
    interp delete slave
    testobj freeallvars
    removeFile io-74.1
} -returnCodes error -match glob -result {can not find channel named "*"}

# ### ### ### ######### ######### #########

# cleanup







|




|



|







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
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 slaves
    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}







|







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
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 slaves
    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} {







|







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
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 slave
    slave eval {
        proc no-op args {}
        proc driver {sub args} {return {initialize finalize watch read}}
        chan event [chan create read driver] readable no-op
    }
    interp delete slave
} {}

# ### ### ### ######### ######### #########
## Same tests as above, but exercising the code forwarding and
## receiving driver operations to the originator thread.

# -*- tcl -*-







|
|




|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

# Custom constraints used in this file







|







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
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
	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 !?!







|







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
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 slaves
    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







|







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
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 slaves
    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







|







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
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 slave
    # Magic to get the test* commands into the slave
    load {} Tcltest slave
} -constraints {testchannel} -body {
    # Get base channel into the slave
    set c [tempchan]
    testchannel cut $c
    interp eval slave [list testchannel splice $c]
    interp eval slave [list set c $c]
    slave 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 slave
} -cleanup {
    tempdone
} -result {}

# ### ### ### ######### ######### #########
## Same tests as above, but exercising the code forwarding and receiving
## driver operations to the originator thread.







|
|
|

|


|
|
|







|







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

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 {[catch {package require tcltest 2.1}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2.1 required."
    return
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

namespace eval ::tcl::test::iogt {
    namespace import ::tcltest::*












>
|
|
<







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
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
    namespace import -force ::tcltest::*
}

test join-1.1 {basic join commands} {
    join {a b c} xyz
} axyzbxyzc
test join-1.2 {basic join commands} {







|







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
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.2
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

set minus -







|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testlink [llength [info commands testlink]]







|







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
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
    namespace import -force ::tcltest::*
}

catch {unset lis}
catch {rename p ""}

test linsert-1.1 {linsert command} {







|







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
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
    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}







|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testobj [llength [info commands testobj]]







|







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
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
    namespace import -force ::tcltest::*
}

test llength-1.1 {length of list} {
    llength {a b c d}
} 4
test llength-1.2 {length of list} {







|







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
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
    namespace import -force ::tcltest::*
}

unset -nocomplain a b i x

# ----- Non-compiled operation -----------------------------------------------








|







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
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
    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













|







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
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, slave 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]







|







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
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
    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}







|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testpurebytesobj [llength [info commands testpurebytesobj]]







|







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
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
    namespace import -force ::tcltest::*
}

## Arg errors
test lrepeat-1.1 {error cases} {
    -body {
	lrepeat












|







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
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
    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} {







|







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
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
    namespace import -force ::tcltest::*
}

set x {abcd bbcd 123 234 345}
test lsearch-1.1 {lsearch command} {
    lsearch $x 123
} 2







|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

proc failTrace {name1 name2 op} {







|







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
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
    namespace import -force ::tcltest::*
}

# Procedure to evaluate a script within a proc, to test compilation
# functionality

proc evalInProc { script } {







|







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
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
    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]












|







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
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
    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]]} {













|







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

3
4
5
6
7
8
9
10
11
12
# This file contains a collection of tests for generic/tclMain.c.


if {[catch {package require tcltest 2.0.2}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
    return
}

namespace eval ::tcl::test::main {
    namespace import ::tcltest::*

    # Is [exec] defined?
    testConstraint exec [llength [info commands exec]]


>
|
<
|







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
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.1
    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::*













|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testhashsystemhash [llength [info commands testhashsystemhash]]







|







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

15
16
17
18
19
20
21
22
23
24
25
#
# 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.


package require Tcl 8.5-
if {[catch {package require tcltest 2}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2 required."
    return
}
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 {







>
|
|
<
<







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
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.2
    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} {







|







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

15
16

17
18
19
20
21
22
23
#
# 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.


package require tcltest 2
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







>
|
|
>







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
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
    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 slave
    # Can't invoke through the ensemble, since deleting the global namespace
    # (indirectly, via deleting ::tcl) deletes the ensemble.
    slave eval {rename ::tcl::info::commands ::infocommands}
    slave hide infocommands
    slave eval {
	proc foo {} {
	    namespace delete ::
	}
    }
} -body {
    slave eval foo
    slave invokehidden infocommands
} -cleanup {
    interp delete slave
} -result {}

test namespace-7.8 {Bug ba1419303b4c} -setup {
    namespace eval ns1 {
	namespace ensemble create
    }








|


|
|
|





|
|

|







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
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
        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 slave
    slave eval {trace add execution error leave {namespace delete :: ;#}}
    catch {slave eval error foo bar baz}
    interp delete slave
    set ::errorInfo
} {bar
    invoked from within
"slave eval error foo bar baz"}
test namespace-8.6 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
    interp create slave
    slave eval {trace add variable errorCode write {namespace delete :: ;#}}
    catch {slave eval error foo bar baz}
    interp delete slave
    set ::errorInfo
} {bar
    invoked from within
"slave eval error foo bar baz"}
test namespace-8.7 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
    interp create slave
    slave eval {trace add execution error leave {namespace delete :: ;#}}
    catch {slave eval error foo bar baz}
    interp delete slave
    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}}







|
|
|
|



|

|
|
|
|



|

|
|
|
|







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
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
	}
    }
} -result 1_2 -cleanup {
    namespace delete ::test_ns_1
    namespace delete ::test_ns_2
}
test namespace-51.16 {Bug 1566526} {
    interp create slave
    slave eval namespace eval demo namespace path ::
    interp delete slave
} {}
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}







|
|
|







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
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
    rename ::unknown unknown.save
    namespace eval :: {
	proc unknown args {
	    return SUCCESS
	}
    }
    catch {rename ::noSuchCommand {}}
    set ::slave [interp create]
} -body {
    $::slave alias bar noSuchCommand
    namespace eval test_ns_1 {
	namespace unknown unknown
	proc unknown args {
	    return FAIL
	}
	$::slave eval bar
    }
} -cleanup {
    interp delete $::slave
    unset ::slave
    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 {







|

|





|


|
|







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
3388
3389
3390
3391
3392
3393
3394
3395
    } [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











|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testevent [llength [info commands testevent]]







|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testnrelevels [llength [info commands testnrelevels]]












|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testobj [llength [info commands testobj]]







|







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
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 != -1)}]
    }
    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}}







|







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

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

package require tcltest 2
if {"::tcltest" in [namespace children]} {
    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.










>
|
<







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
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 slave
} -body {
    slave eval {
	oo::define [oo::class create foo] superclass oo::class
	oo::class destroy
    }
} -cleanup {
    interp delete slave
}
test oo-1.18.4 {correct handling of cleanup in superclass set error} -setup {
    interp create slave
} -body {
    slave 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 slave
} -result {class should only be a direct superclass once}
test oo-1.18.5 {correct handling of cleanup in superclass set error} -setup {
    interp create slave
} -body {
    slave 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 slave
} -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"}







|

|




|


|

|











|


|

|











|







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
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 ::master
    namespace eval ::foo {
	oo::class create mixin {superclass ::master}
    }
} -cleanup {
    ::master destroy
    namespace delete ::foo
} -body {
    namespace eval ::foo {
	oo::class create bar {superclass master}
	oo::class create boo
	oo::define boo {superclass bar}
	oo::define boo {mixin mixin}
	oo::class create spong {superclass boo}
	return
    }
} -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
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 master
} -cleanup {
    master destroy
} -body {
    oo::class create A {
	superclass master
	method egg {} {
	    return chicken
	}
    }
    oo::class create B {
	superclass master
	mixin A
	method bar {} {
	    # mixin from A
	    my egg
	}
    }
    oo::class create C {
	superclass master
	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 master
} -cleanup {
    master destroy
} -body {
    oo::class create A {
	superclass master
	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 master
	mixin A
	filter f
	method bar {} {
	    # mixin from A
	    my egg
	}
    }
    oo::class create C {
	superclass master
	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 master {
	method test {} {}
    }
} -cleanup {
    master destroy
} -body {
    oo::class create mix {
	superclass master
	method test {} {lappend ::result mix; next; return $::result}
    }
    oo::class create cls {
	superclass master
	mixin mix
	method test {} {lappend ::result cls; next; return $::result}
    }
    [cls new] test
} -result {mix cls}

test oo-15.1 {OO: object cloning} {







|

|


|





|







|









|

|


|










|








|











|



|


|



|







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
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 master
    oo::class create ::foo {superclass master}
} -body {
    catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt
    dict get $opt -errorinfo
} -cleanup {
    master 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 master
    set c [oo::class create now_this_is_a_very_very_long_class_name_indeed {
        superclass master
    }]
} -body {
    catch {oo::define $c {error err}} msg opt
    dict get $opt -errorinfo
} -cleanup {
    master 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 master
    oo::class create ::foo {superclass master}
} -body {
    catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt
    dict get $opt -errorinfo
} -cleanup {
    master 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 master
    oo::class create ::foo {superclass master}
} -body {
    catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt
    dict get $opt -errorinfo
} -cleanup {
    master 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}}"}








|
|




|










|

|





|







|
|




|










|
|




|







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
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 master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	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 master
    set result bad!
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	variable x!
	constructor {} {set x! 1}
	method y {} {incr x!}
	destructor {set ::result ${x!}}
    }
    foo create bar
    bar y







|

|


|









|


|


|







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
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 master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	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 master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	variable x!
	constructor {} {set x! 1}
	method y {} {incr x!}
    }
    oo::class create foo2 {
	superclass foo
	variable y!







|

|


|














|

|


|







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
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 master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	variable clsvar
	constructor {} {
	    set clsvar 0
	}
	method step {} {
	    incr clsvar
	    return







|

|


|







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
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 master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	variable clsvar
	constructor {} {
	    set clsvar 0
	}
	method step {} {
	    incr clsvar
	    return







|

|


|







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
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 master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	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 master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	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 master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	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 master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	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 master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	variable x
	variable -? y
	method boo {} {
	    return [incr x],[incr y]
	}
    }
    foo create bar







|

|


|










|

|


|










|

|


|











|

|


|










|

|


|







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
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 Master {
	superclass Super
	variable member1 member2
	constructor {} {
	    set member1 master1
	    set member2 master2
	}
	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 {
    [[Master new] getChild] result
} -cleanup {
    Super destroy
} -result {master1 master2 master1 master2 master1 master2 master1 master2}

# 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 {







|



|
|




















|


|







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

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

package require tcltest 2
if {"::tcltest" in [namespace children]} {
    namespace import -force ::tcltest::*
}

testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
    proc getbytes {} {
	set lines [split [memory info] \n]










>
|
<







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
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 Master
	oo::class create Foo {
	    superclass Master
	    method bar {} {
		puts abc
		tailcall puts hi
		puts xyz
	    }
	}
	oo::class create Foo2 {
	    superclass Master
	}
    }
    -cleanup {
	Master 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







|

|







|



|







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

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

package require tcltest 2
if {"::tcltest" in [namespace children]} {
    namespace import -force ::tcltest::*
}

test ooUtil-1.1 {TIP 478: classmethod} -setup {
    oo::class create parent
} -body {
    oo::class create ActiveRecord {












>
|
<







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
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 master 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]







|







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
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
    namespace import -force ::tcltest::*
}

# the package we are going to test
package require opt 0.4.7

# we are using implementation specifics to test the package


#### functions tests #####

set n $::tcl::OptDescN







|




|







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
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.3.3
    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







|







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

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 {[catch {package require tcltest 2.0.2}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
    return
}

namespace eval ::tcl::test::parse {
    namespace import ::tcltest::*

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]










>
|
<
|







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
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 ::slave [interp create]
    $::slave alias bar noSuchCommand
    set ::info {}
    namespace eval test_ns_1 {
       proc foo args {lappend ::info namespace}
       $::slave eval bar
       testevalobjv 1 [list $::slave eval bar]
       uplevel #0 [list $::slave eval bar]
    }
    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 ::slave [interp create]
    $::slave alias bar noSuchCommand
    set ::info {}
    namespace eval test_ns_1 {
        $::slave eval bar
    }
    namespace delete test_ns_1
    interp delete $::slave
    catch {rename ::noSuchCommand {}}
    set ::info
} global


test parse-9.1 {Tcl_LogCommandInfo, line numbers} testevalex {
    unset -nocomplain x







|
|



|
|
|
















|
|


|


|







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

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.


package require tcltest 2
namespace import ::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










>
|
|
>







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

16
17

18
19
20
21
22
23
24
# 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.


package require tcltest 2
namespace import ::tcltest::*


::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testwordend [llength [info commands testwordend]]
testConstraint testbytestring [llength [info commands testbytestring]]








>
|
|
>







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
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
    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]







|







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

11
12

13
14
15
16
17
18
19
# 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.


package require tcltest 2
namespace import ::tcltest::*


set fullPkgPath [makeDirectory pkg]

namespace eval pkgtest {
    # Namespace for procs we can discard
}











>
|
|
>







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
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
#
# 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 slave interpreter, where we override "package ifneeded"

    set slave [interp create]
    if {[catch {
	$slave 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]
	$slave eval {set curdir [pwd]}
	$slave eval [list cd $dir]
	$slave eval [list set dir $dir]
	$slave eval [list source [file tail $filePath]]
	$slave eval {cd $curdir}

	# Create the list in sorted order, so that we don't get spurious
	# errors because the order has changed.

	array set P {}
	foreach {k v} [$slave eval {array get ::PKGS}] {
	    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 $slave}

	error $ei $ec
    }

    interp delete $slave

    return $PKGS
}

# pkgtest::createIndex --
#
#  Runs pkg_mkIndex for the given directory and set of patterns.  This







|

|

|














|
|
|
|
|





|











|




|







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
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

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.











|







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
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
    namespace import -force ::tcltest::*
}

catch {rename t1 ""}
catch {rename foo ""}

proc tproc {} {return a; return b}







|







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
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
    namespace import -force ::tcltest::*
}

testConstraint procbodytest [expr {![catch {package require procbodytest}]}]
testConstraint memory	    [llength [info commands memory]]

catch {namespace delete {*}[namespace children :: test_ns_*]}







|







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
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 slave
    slave eval [list apply $lambda foo]
    interp delete slave
    unset lambda
} {}

test proc-7.5 {[631b4c45df] Crash in argument processing} {
    binary scan A c val
    proc foo [list  [list from $val]] {}
    rename foo {}







|
|
|







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
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
    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)











|







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
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
    namespace import -force ::tcltest::*
}

test pwd-1.1 {simple pwd} {
    catch pwd
} 0
test pwd-1.2 {simple pwd} {







|







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
13

14
15
16
17
18
19
20
# 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

}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

# All tests require the testregexp command, return if this
# command doesn't exist












|
>







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
290
291
292
293
294
295
296
297

	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 == -1} {
	    # 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]







|







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
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
    namespace import -force ::tcltest::*
}

unset -nocomplain foo

testConstraint exec [llength [info commands exec]]








|







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
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
    namespace import -force ::tcltest::*
}

# Procedure to evaluate a script within a proc, to test compilation
# functionality

proc evalInProc { script } {







|







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
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
    namespace import -force ::tcltest::*
}

testConstraint reg 0
if {[testConstraint win]} {
    if {![catch {
	    ::tcltest::loadTestedCommands













|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testdel [llength [info commands testdel]]







|







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

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.


package require tcltest 2
if {"::tcltest" in [namespace children]} {
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testinterpresolver [llength [info commands testinterpresolver]]












>
|
<







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
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 slave
# interpreter per test-case.
#
#
# Testing resolver in namespace-based context "ctx1"
#
test resolver-3.1a {
    interp command resolver,







|







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

13
14

15
16
17
18
19
20
21
# 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.


package require tcltest 2
namespace import ::tcltest::*


::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

# Some tests require the testsaveresult command

testConstraint testsaveresult      [llength [info commands testsaveresult]]












>
|
|
>







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
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
# 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.

package require Tcl 8.5-

if {"::tcltest" ni [namespace children]} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

foreach i [interp slaves] {
    interp delete $i
}

set saveAutoPath $::auto_path
set ::auto_path [info library]


















# 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 "slave" (use -help for full usage) :
    slave name () name of the slave}
test safe-1.2 {safe::interpCreate syntax} -returnCodes error -body {
    safe::interpCreate -help
} -result {Usage information:
    Var/FlagName  Type     Value   Help
    ------------  ----     -----   ----
    (-help                         gives this help)
    ?slave?       name     ()      name of the slave (optional)
    -accessPath   list     ()      access path for the slave
    -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
    slave name () name of the slave}

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


} -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 {





>
>
>
>
>
>
>
>
>
>







<
<

|



|



|

>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|










|
|






|
|








|












>
>







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



141












142






















































143
144



145






146












147
148








149




150

151
152
153
154
155
156
157
158
} -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 ""




# The following test checks whether the definition of tcl_endOfWord can be












# obtained from auto_loading.























































test safe-5.1 {test auto-loading in safe interpreters} -setup {



    catch {safe::interpDelete a}






    safe::interpCreate a












} -body {
    interp eval a {tcl_endOfWord "" 0}








} -cleanup {




    safe::interpDelete a

} -result -1

# 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







>
>







>
>
















>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
>
>
>
|
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>

<
>
>
>
>
>
>
>
>

>
>
>
>
|
>
|







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

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
    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

test safe-7.1 {tests that everything works at high level} -body {


    set i [safe::interpCreate]


    # no error shall occur:
    # (because the default access_path shall include 1st level sub dirs so
    #  package require in a slave works like in the master)
    set v [interp eval $i {package require http 2}]
    # no error shall occur:
    interp eval $i {http::config}
    safe::interpDelete $i
    set v


} -match glob -result 2.*
test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body {




















































    set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
    # should not add anything (p0)
    set token1 [safe::interpAddToAccessPath $i [info library]]
    # should add as p1
    set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
    # an error shall occur (http is not anymore in the secure 0-level
    # provided deep path)

    list $token1 $token2 \
	    [catch {interp eval $i {package require http 1}} msg] $msg \
	    [safe::interpConfigure $i]\
	    [safe::interpDelete $i]
} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}"
test safe-7.3 {check that safe subinterpreters work} {
    set i [safe::interpCreate]
    set j [safe::interpCreate [list $i x]]
    list [interp eval $j {join {o k} ""}] [safe::interpDelete $i] [interp exists $j]
} {ok {} 0}

# test source control on file name
set i "a"
test safe-8.1 {safe source control on file} -setup {

    catch {safe::interpDelete $i}
} -body {
    safe::interpCreate $i
    $i eval {source}
} -returnCodes error -cleanup {
    safe::interpDelete $i

} -result {wrong # args: should be "source ?-encoding E? fileName"}
test safe-8.2 {safe source control on file} -setup {

    catch {safe::interpDelete $i}
} -body {
    safe::interpCreate $i
    $i eval {source a b c d e}
} -returnCodes error -cleanup {
    safe::interpDelete $i

} -result {wrong # args: should be "source ?-encoding E? fileName"}
test safe-8.3 {safe source control on file} -setup {

    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
    unset log
    safe::interpDelete $i


} -result {1 {permission denied} {{ERROR for slave a : ".": is a directory}}}
test safe-8.4 {safe source control on file} -setup {

    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
    unset log
    safe::interpDelete $i


} -result {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}}}
test safe-8.5 {safe source control on file} -setup {

    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
    unset log
    safe::interpDelete $i


} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"]]
test safe-8.6 {safe source control on file} -setup {

    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
    unset log
    safe::interpDelete $i


} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"]]
test safe-8.7 {safe source control on file} -setup {

    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
    unset log
    safe::interpDelete $i


} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]]
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 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

} -result ok
test safe-8.10 {safe source and return} -setup {

    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

} -result ok

set i "a"
test safe-9.1 {safe interps' deleteHook} -setup {

    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



} -result {{} {arg1 arg2 a}}
test safe-9.2 {safe interps' error in deleteHook} -setup {

    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


    unset log
} -result {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}}}
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]
} {}







>




>
|
>
>

>
>


|
|

|
<

>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



|
|
|
|
>
|
|
<
|
|
|
|
|
|
<


<

>






>


>






>


>










<

>
>
|

>










<

>
>
|

>














<

>
>
|

>












<

>
>
|

>














<

>
>
|





>









>


>












>


<

>












>
>
>


>




















>
>
|
|







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


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
	[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]


} -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}}


























































































































































































































































































































































































































































































































































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 {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 {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}







>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








|








|







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
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
    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 {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 {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]







|







|







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
682
683
684
685
686
687
688













689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
    ::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 which gives a deliberate error in a safe interpreter [Bug 2964715]} -setup {
    set i [safe::interpCreate]
    buildEnvironment pkgIndex.tcl
} -body {
    set safeTD [::safe::interpAddToAccessPath $i $testdir]
    ::safe::interpAddToAccessPath $i $testdir2
    string map [list $safeTD EXPECTED] [$i eval [list \













	glob -directory $safeTD -join * pkgIndex.tcl]]
} -cleanup {
    safe::interpDelete $i
    removeDirectory $testdir
} -result {{EXPECTED/deletemetoo/pkgIndex.tcl}}
# Note the extra {} around the result above; that's *expected* because of the
# format of virtual path roots.
test safe-13.8 {mimic the glob call by tclPkgUnknown without the deliberate error that is specific to pkgIndex.tcl [Bug 2964715]} -setup {
    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 {







|





|
>
>
>
>
>
>
>
>
>
>
>
>
>




|
|
<
|







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
736
737
738
739
740
741
742
743
    ::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
test safe-14.1 {Check that module path is the same as in the master 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







>


|







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








830





































831
832




833
834
835
836
837
838
    $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 {}














































set ::auto_path $saveAutoPath
# cleanup




::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:







>









>














>









>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|

>
>
>
>






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
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
    namespace import -force ::tcltest::*
}

# procedure that returns the range of integers

proc int_range {} {
    set MAX_INT [expr {[format %u -2]/2}]







|







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
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
    namespace import -force ::tcltest::*
}

# If this proc becomes invoked, then there is a bug

proc BUG {args} {
    set ::BUG 1













|







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
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
    namespace import -force ::tcltest::*
}

proc ignore args {}

# Simple variable operations.








|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testset2 [llength [info commands testset2]]













|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
::tcltest::loadTestedCommands








|







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
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] != -1} {
    	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"
    }
}

#







|







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
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
      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 ::master [thread::id]
    # helper thread creating async connection and initiating transfer (detach) to master:
    set ::helper [thread::create]
    thread::send -async $::helper [list \
      lassign [list $::master $::localhost $port $testmode] \
                     ::master ::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 $::master {set ::count "ERROR: invalid thread, $::helper is expecting"}
              close $fd
              return
            }
          }} $fd]
        };#
        thread::detach $fd
        thread::send -async $::master [list transf_master $fd {*}$args]
      }
      iteration first
    }
    # master proc commiting transfer attempt (attach) and checking acquire was successful:
    proc transf_master {fd args} {
      tcltest::DebugPuts 1 "** trma / $::count ** $args **"
      thread::attach $fd
      if {"master-close" in $::testmode} {;# to test close during connect
        set ::count $::count
        close $fd
        return
      };#
      fileevent $fd writable [list apply {{fd} {
        if {[thread::id] ne $::master} {
          thread::send -async $::master {set ::count "ERROR: invalid thread, $::master is expecting"}
          close $fd
          return
        }
        set ::count $::count
        close $fd
      }} $fd]
    }







|
|


|
|








|






|



|
|


|





|
|







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
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
    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 ::master ::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 {master-close} 100
} -result 100 -constraints [list socket supported_$af thread]
test socket_$af-13.2.cl2 {Testing socket transfer between threads during async connect} -body {
    transf_test {master-close helper-writable} 100
} -result 100 -constraints [list socket supported_$af thread]
catch {rename transf_master {}}
rename transf_test {}

# ----------------------------------------------------------------------

removeFile script1
removeFile script2








|









|


|

|







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
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
    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} {







|







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

12
13

14
15
16
17
18
19
20
# 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.


package require tcltest 2
namespace import ::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 }











>
|
|
>







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
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
    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.







|







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
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
    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 != -1}]
} {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]







|














|
|







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
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.1
    namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testbytestring [llength [info commands testbytestring]]








|







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
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 slave
    slave eval [list source $script]
    interp delete slave
    interp create slave
    slave eval {
	set count 400
	while {[incr count -1]} {
	    lappend bloat [expr {rand()}]
	}
    }
    slave eval [list source $script]
    interp delete slave
} -cleanup {
    removeFile subst13.tcl
}
test subst-13.2 {Test for segfault} -body {
    subst {[}
} -returnCodes error -result * -match glob








|
|
|
|
|





|
|







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
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
    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} {







|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testnrelevels [llength [info commands testnrelevels]]












|







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
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 slave interp so the [test] being tested would not
# interfere with the [test] doing the testing.
#


if {[catch {package require tcltest 2.1}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2.1 required."
    return
}

namespace eval ::tcltest::test {

namespace import ::tcltest::*

makeFile {
    package require tcltest
    namespace import ::tcltest::test
    test a-1.0 {test a} {
	list 0
    } {0}
    test b-1.0 {test b} {
	list 1
    } {0}







|



>
|
|
<







|







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
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 slave {msgVar args} {
    upvar 1 $msgVar msg

    interp create [namespace current]::i
    # Fake the slave 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]]







|



|







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
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 [slave msg test.tcl]
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 0 0 1}
test tcltest-2.1 {tcltest -verbose 'b'} {unixOrWin} {
    set result [slave msg test.tcl -verbose 'b']
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 0 0 1}
test tcltest-2.2 {tcltest -verbose 'p'} {unixOrWin} {
    set result [slave msg test.tcl -verbose 'p']
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 1 0 1}
test tcltest-2.3 {tcltest -verbose 's'} {unixOrWin} {
    set result [slave msg test.tcl -verbose 's']
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 0 1 1}
test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrWin} {
    set result [slave msg test.tcl -verbose 'ps']
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 1 1 1}
test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrWin} {
    set result [slave msg test.tcl -verbose 'psb']
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 1 1}

test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrWin} {
    set result [slave msg test.tcl -verbose "pass skip body"]
    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 [slave 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 [slave 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}  {







|





|





|





|





|





|






|








|









|







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
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 [slave 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 [slave msg test.tcl -match a* -verbose 'ps']
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 1 0 0 1}
test tcltest-3.2 {tcltest -match 'b*'} {unixOrWin} {
    set result [slave msg test.tcl -match b* -verbose 'ps']
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
} {0 0 1 0 1}
test tcltest-3.3 {tcltest -match 'c*'} {unixOrWin} {
    set result [slave msg test.tcl -match c* -verbose 'ps']
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg]
} {0 0 0 1 1}
test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrWin} {
    set result [slave msg test.tcl -match {a* b*} -verbose 'ps']
    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 [slave msg test.tcl -skip a* -verbose 'ps']
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg]
} {0 0 1 1 1}
test tcltest-4.2 {tcltest -skip 'b*'} {unixOrWin} {
    set result [slave msg test.tcl -skip b* -verbose 'ps']
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
} {0 1 0 1 1}
test tcltest-4.3 {tcltest -skip 'c*'} {unixOrWin} {
    set result [slave msg test.tcl -skip c* -verbose 'ps']
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 0 1}
test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrWin} {
    set result [slave msg test.tcl -skip {a* b*} -verbose 'ps']
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
} {0 0 0 1 1}
test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrWin} {
    set result [slave msg test.tcl -match {a* b*} -skip b* -verbose 'ps']
    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 [slave msg test.tcl -constraints knownBug -verbose 'ps']
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg]
} {0 1 1 1 1}
test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrWin} {
    set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1]
    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]







|







|




|




|




|



















|




|




|




|




|




















|




|







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
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
    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 {
	slave msg $printerror
	return $msg
    }
    -result {a test.*a really}
    -match regexp
}
test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrWin unixExecs} {
    slave msg $printerror -outfile a.tmp
    set result1 [catch {exec grep "a test" a.tmp}]
    set result2 [catch {exec grep "a really" a.tmp}]
    list [regexp "a test" $msg] [regexp "a really" $msg] \
	    $result1 $result2 [file exists a.tmp] [file delete a.tmp]
} {0 1 0 1 1 {}}
test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrWin unixExecs} {
    slave msg $printerror -errfile a.tmp
    set result1 [catch {exec grep "a test" a.tmp}]
    set result2 [catch {exec grep "a really" a.tmp}]
    list [regexp "a test" $msg] [regexp "a really" $msg] \
	    $result1 $result2 [file exists a.tmp] [file delete a.tmp]
} {1 0 1 0 1 {}}
test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrWin unixExecs} {
    slave msg $printerror -outfile a.tmp -errfile b.tmp
    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 {}}







|
















|






|






|






|







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
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
# slave 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] \







|







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
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
    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 {
    slave 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 {
	slave 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]







|














|







|







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
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 {
	slave 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 {
	slave msg $a -tmpdir $notWriteableDir
	return $msg
    }
    -result {*not writeable*}
    -match glob
}
test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {
    -constraints unixOrWin
    -body {
	slave 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]}
    }







|















|








|







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
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 {
	slave msg $a -testdir thisdirectorydoesnotexist
	return $msg
    }
    -match glob
    -result {*does not exist*}
}
test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {
    -constraints unixOrWin
    -body {
	slave 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 {
	slave msg $a -testdir $notReadableDir
	return $msg
    }
    -match glob
    -result {*not readable*}
}
test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {
    -constraints unixOrWin
    -body {
	slave 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]







|








|








|








|







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
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 {
    slave 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 {
    slave 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}  {







|









|







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
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 {
    slave 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
    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} {
    slave msg $mc -preservecore 0
    file delete core
    regexp "Core file produced" $msg
} {0}
test tcltest-10.2 {-preservecore 1} {unixOrWin} {
    slave msg $mc -preservecore 1
    file delete core
    regexp "Core file produced" $msg
} {1}
test tcltest-10.3 {-preservecore 2} {unixOrWin} {
    slave msg $mc -preservecore 2
    file delete core
    list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
	    [regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}
test tcltest-10.4 {-preservecore 3} {unixOrWin} {
    slave msg $mc -preservecore 3
    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







|










|











|




|




|





|







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
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
    namespace import tcltest::*
    puts [outputChannel] $::tcltest::loadScript
    exit
}
set loadfile [makeFile $contents load.tcl]

test tcltest-12.1 {-load xxx} {unixOrWin} {
    slave 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 \







|







|







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
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
    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 {
	slave 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 {
	slave 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} {







|









|









|







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
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
    namespace import -force tcltest::*
    testsDirectory [file join [temporaryDirectory] dirtestdir]
    runAllTests
} all.tcl $dtd
makeFile {
    package require tcltest
    namespace import -force tcltest::*
    testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.1]
    runAllTests
} all.tcl $dtd1
makeFile {
    package require tcltest
    namespace import -force tcltest::*
    testsDirectory [file join [temporaryDirectory]  dirtestdir dirtestdir2.2]
    runAllTests
} all.tcl $dtd2
makeFile {
    package require tcltest
    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 {[slave 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 {[slave 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 {[slave 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 {[slave 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 {[slave msg \
		[file join $dtd all.tcl] \
		-relateddir "dirtestdir2.1 dirtestdir2.2" \
		-asidefromdir dirtestdir2.2 \
		-tmpdir [temporaryDirectory]] == 1} {
	    error $msg
	}
    }







|





|





|





|








|













|

















|














|












|







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
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 slave1
	slave1 eval [list set argv {-debug 2}]
	slave1 alias puts puts
	interp create slave2
	slave2 alias puts puts
    } -cleanup {
	interp delete slave2
	interp delete slave1
	if {$oldoptions eq "none"} {
	    unset ::env(TCLTEST_OPTIONS)
	} else {
	    set ::env(TCLTEST_OPTIONS) $oldoptions
	}
    } -body {
	slave1 eval [package ifneeded tcltest [package provide tcltest]]
	slave1 eval tcltest::debug
	set ::env(TCLTEST_OPTIONS) "-debug 3"
	slave2 eval [package ifneeded tcltest [package provide tcltest]]
	slave2 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 [slave 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








|
|
|
|
|

|
|






|
|

|
|








|







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
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
    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
    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 slave interp.
test tcltest-22.1 {runAllTests} {
    -constraints {unixOrWin}
    -body {
	exec [interpreter] \
		[file join $atd all.tcl] \
		-verbose t -tmpdir [temporaryDirectory]
    }







|











|









|







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
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
	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 {
    slave 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
	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 {
    slave msg [file join [temporaryDirectory] test.tcl]
    return $msg
} -cleanup {
    removeFile test.tcl
} -match glob -result {*
---- errorInfo: body error
*
---- errorInfo(cleanup): cleanup error*}







|









|









|









|







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
3
4
5
6
7
8
9
10
#! /usr/bin/env tclsh

package require tcltest 2.2
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]}]


|







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
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
    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







|







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
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 != -1} then {
        return [lindex $list $idx]
    }
    set idx [lsearch -glob $list "*eval*canceled*"]
    if {$idx != -1} then {
        return [lindex $list $idx]
    }
    return ""; # some other error we do not care about.
}

proc findThreadError { info } {
    foreach error [lreverse $info] {







|



|







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
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: slave 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 {







|







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
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: slave 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 {







|







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
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
    namespace import -force ::tcltest::*
}

test timer-1.1 {Tcl_CreateTimerHandler procedure} -setup {
    foreach i [after info] {
	after cancel $i
    }







|







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
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 slave
    slave eval namespace export after
    slave eval namespace eval foo namespace import ::after
} -body {
    slave eval foo::after 1
    slave eval namespace origin foo::after
} -cleanup {
    # Bug will cause crash here; would cause failure otherwise
    interp delete slave
} -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







|
|
|

|
|


|







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
9
10
11
12
13
14
15
16
17
18
# 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.

package require Tcl 8.5-
if {"::tcltest" ni [namespace children]} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

test tm-1.1 {tm: path command exists} {
    catch { ::tcl::tm::path }
    info commands ::tcl::tm::path
} ::tcl::tm::path








<

|







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

14
15

16
17
18
19
20
21
22
# 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.


package require tcltest
namespace import ::tcltest::*


::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevalobjv [llength [info commands testevalobjv]]














>
|
|
>







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
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
foo {if {[catch {bar}]} {
	    return "error"
	} else {
	    return "ok"
	}} 2 error leavestep
foo foo 0 error leave}}

test trace-28.4 {exec traces in slave with 'return -code error'} {
    interp create slave
    interp alias slave traceExecute {} traceExecute
    set info {}
    set res [interp eval slave {
	set info {}
	set res {}

	proc foo {} {
	    if {[catch {bar}]} {
		return "error"
	    } else {







|
|
|

|







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
2232
2233
2234
2235
2236
2237
2238
2239
	lappend res [foo]

	trace remove execution foo {enter enterstep leave leavestep} \
	  [list traceExecute foo]

	list $res
    }]
    interp delete slave
    lappend res [join $info \n]
} {{error error} {foo foo enter
foo {if {[catch {bar}]} {
		return "error"
	    } else {
		return "ok"
	    }} enterstep







|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testchmod [llength [info commands testchmod]]












|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testfindexecutable [llength [info commands testfindexecutable]]












|







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

11
12

13
14
15
16
17
18
19
# 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.


package require tcltest 2
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} \










>
|
|
>







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

13
14

15
16
17
18
19
20
21
# 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.


package require tcltest 2.2
namespace import ::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]]













>
|
|
>







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
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
    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-}]}]














|







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

14
15

16
17
18
19
20
21
22
# 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.


package require tcltest 2
namespace import ::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_"}}













>
|
|
>







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
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
    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







|







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
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] == -1} {
	load [file join $testDir pkgb$ext] pKgB child
    }
} -constraints [list $dll $loaded] -returnCodes error -match glob -body {
    unload [file join $testDir pkgb$ext] {} child
} -result {file "*" cannot be unloaded under a safe interpreter}
test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for package name} -setup {
    if {[lsearch -index 1 [info loaded child] Pkgua] == -1} {
	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}]







|






|







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
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
    namespace import -force ::tcltest::*
}

proc a {x y} {
    newset z [expr $x+$y]
    return $z
}







|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testupvar [llength [info commands testupvar]]







|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint ucs2 [expr {[format %c 0x010000] eq "\uFFFD"}]











|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint controversialNaN 1










|







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
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.2
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testupvar [llength [info commands testupvar]]







|







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
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 slave
	slave eval {
	    proc doit script {
		eval $script
		set foo bar
	    }
	    doit {foreach foo baz {}}
	}
	interp delete slave
    }
} -constraints memory -body {
    set end [getbytes]
    for {set i 0} {$i < 5} {incr i} {
	doit
        set tmp $end
        set end [getbytes]







|
|






|







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
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
    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







|







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
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
    namespace import -force ::tcltest::*
}

# Basic "while" operation.

catch {unset i}
catch {unset a}













|







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
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
    namespace import -force ::tcltest::*
}


test winConsole-1.1 {Console file channel: non-blocking gets} {win interactive} {
    set oldmode [fconfigure stdin]













|







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
13
14
15
16
17
18
19
20
21
# 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
    #tcltest::configure -verbose {pass start}
    namespace import -force ::tcltest::*
}

testConstraint debug [::tcl::pkgconfig get debug]
testConstraint dde 0
if {[testConstraint win]} {
    if {![catch {












|
<







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
46
47
48
49
50
51
52
53
    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
	    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







|







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
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
} -cleanup {
    dde execute TclEval $name {set done 1}
    update
} -result "ch\xEDld-6.6"

# -------------------------------------------------------------------------

test winDde-7.1 {Load DDE in slave interpreter} -constraints dde -setup {
    interp create slave
} -body {
    slave eval [list load $::ddelib Dde]
    slave eval [list dde servername -- dde-interp-7.1]
} -cleanup {
    interp delete slave
} -result {dde-interp-7.1}
test winDde-7.2 {DDE slave cleanup} -constraints dde -setup {
    interp create slave
    slave eval [list load $::ddelib Dde]
    slave eval [list dde servername -- dde-interp-7.5]
    interp delete slave
} -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 slave interp} -constraints dde -setup {
    interp create slave
    slave eval [list load $::ddelib Dde]
    slave eval [list dde servername -- dde-interp-7.3]
} -body {
    dde services TclEval dde-interp-7.3
} -cleanup {
    interp delete slave
} -result {{TclEval dde-interp-7.3}}
test winDde-7.4 {interp name collision with -force} -constraints dde -setup {
    interp create slave
    slave eval [list load $::ddelib Dde]
    slave eval [list dde servername -- dde-interp-7.4]
} -body {
    dde servername -force -- dde-interp-7.4
} -cleanup {
    interp delete slave
} -result {dde-interp-7.4}
test winDde-7.5 {interp name collision without -force} -constraints dde -setup {
    interp create slave
    slave eval [list load $::ddelib Dde]
    slave eval [list dde servername -- dde-interp-7.5]
} -body {
    dde servername -- dde-interp-7.5
} -cleanup {
    interp delete slave
} -result "dde-interp-7.5 #2"

# -------------------------------------------------------------------------

test winDde-8.1 {Safe DDE load} -constraints dde -setup {
    interp create -safe slave
    slave invokehidden load $::ddelib Dde
} -body {
    slave eval dde servername slave
} -cleanup {
    interp delete slave
} -returnCodes error -result {invalid command name "dde"}
test winDde-8.2 {Safe DDE set servername} -constraints dde -setup {
    interp create -safe slave
    slave invokehidden load $::ddelib Dde
} -body {
    slave invokehidden dde servername slave
} -cleanup {interp delete slave} -result {slave}
test winDde-8.3 {Safe DDE check handler required for eval} -constraints dde -setup {
    interp create -safe slave
    slave invokehidden load $::ddelib Dde
    slave invokehidden dde servername slave
} -body {
    catch {dde eval slave set a 1} msg
} -cleanup {interp delete slave} -result {1}
test winDde-8.4 {Safe DDE check that execute is denied} -constraints dde -setup {
    interp create -safe slave
    slave invokehidden load $::ddelib Dde
    slave invokehidden dde servername slave
} -body {
    slave eval set a 1
    dde execute TclEval slave {set a 2}
    slave eval set a
} -cleanup {interp delete slave} -result 1
test winDde-8.5 {Safe DDE check that request is denied} -constraints dde -setup {
    interp create -safe slave
    slave invokehidden load $::ddelib Dde
    slave invokehidden dde servername slave
} -body {
    slave eval set a 1
    dde request TclEval slave a
} -cleanup {
    interp delete slave
} -returnCodes error -result {remote server cannot handle this command}
test winDde-8.6 {Safe DDE assign handler procedure} -constraints dde -setup {
    interp create -safe slave
    slave invokehidden load $::ddelib Dde
    slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
} -body {
    slave invokehidden dde servername -handler DDEACCEPT slave
} -cleanup {interp delete slave} -result slave
test winDde-8.7 {Safe DDE check simple command} -constraints dde -setup {
    interp create -safe slave
    slave invokehidden load $::ddelib Dde
    slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
    slave invokehidden dde servername -handler DDEACCEPT slave
} -body {
    dde eval slave set x 1
} -cleanup {interp delete slave} -result {set x 1}
test winDde-8.8 {Safe DDE check non-list command} -constraints dde -setup {
    interp create -safe slave
    slave invokehidden load $::ddelib Dde
    slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
    slave invokehidden dde servername -handler DDEACCEPT slave
} -body {
    set s "c:\\Program Files\\Microsoft Visual Studio\\"
    dde eval slave $s
    string equal [slave eval set DDECMD] $s
} -cleanup {interp delete slave} -result 1
test winDde-8.9 {Safe DDE check command evaluation} -constraints dde -setup {
    interp create -safe slave
    slave invokehidden load $::ddelib Dde
    slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
    slave invokehidden dde servername -handler DDEACCEPT slave
} -body {
    dde eval slave set \xe1 1
    slave eval set \xe1
} -cleanup {interp delete slave} -result 1
test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints dde -setup {
    interp create -safe slave
    slave invokehidden load $::ddelib Dde
    slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
    slave invokehidden dde servername -handler DDEACCEPT slave
} -body {
    dde eval slave [list set x 1]
    slave eval set x
} -cleanup {interp delete slave} -result 1
test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints dde -setup {
    interp create -safe slave
    slave invokehidden load $::ddelib Dde
    slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
    slave invokehidden dde servername -handler DDEACCEPT slave
} -body {
    dde eval slave [list [list set x 1]]
    slave eval set x
} -cleanup {interp delete slave} -returnCodes error -result {invalid command name "set x 1"}

# -------------------------------------------------------------------------

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







|
|

|
|

|

|
|
|
|
|








|
|
|
|



|


|
|
|



|


|
|
|



|





|
|

|

|


|
|

|
|

|
|
|

|
|

|
|
|

|
|
|
|

|
|
|

|
|

|


|
|
|

|
|

|
|
|
|

|
|

|
|
|
|


|
|
|

|
|
|
|

|
|
|

|
|
|
|

|
|
|

|
|
|
|

|
|
|







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
484
485
486
487
488
489
490
491
    update
    file delete -force -- dde-script.tcl
} -result {null data}

# -------------------------------------------------------------------------

#cleanup
#catch {interp delete $slave};           # ensure we clean up the slave.
file delete -force $::scriptName
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:







|







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

# Initialise the test constraints













|







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
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)]] != -1} {
            return [list [file join $dirname Test$n] $filename]
        }
        lappend inodes $stat(ino)
        unset 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

13
14
15
16
17
18
19
20
21
22
23
24
# 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 {[catch {package require tcltest 2.0.2}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
    return
}
namespace import -force ::tcltest::*

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint notNTFS 0













>
|
<
|

<







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testeventloop [expr {[info commands testeventloop] != {}}]













|







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

15
16

17
18
19
20
21
22
23
#
# 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.


package require tcltest
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]
}







>
|
|
>







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
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
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testwinclock [llength [info commands testwinclock]]













|







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
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.1
    namespace import -force ::tcltest::*
}

testConstraint zipfs [expr {
    [llength [info commands zlib]] && [regexp tcltest [info nameofexecutable]]
}]
testConstraint zipfslib 1













|







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
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.1
    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













|







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
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] != -1} {
        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 {







|







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
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 == -1} {
	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 == -1} {
	set pIndex [llength $pages]
	lappend pages $info
    }
    lappend pMap [expr {$pIndex << $shift}]
    return
}








|












|







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
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
	@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.3 as a Tcl Module"
	@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \
		"$(MODULE_INSTALL_DIR)/9.0/http-2.9.3.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"







|

|







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
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
	    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 master
# 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







|
|
|







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
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_IO_FAILURE 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_IO_FAILURE;
    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;







|


















|







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
894
895
896
897
898
899
900
901
902
	    $(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.3 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/9.0/http-2.9.3.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";







|
|







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
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.







|







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
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. This is the "master" copy and kept updated.
#
# 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.
#







|







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
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 "master" 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.







|







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
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 master makefile should define explicit rules.

{$(ROOT)}.c{$(TMP_DIR)}.obj::
	$(CCPKGCMD) @<<
$<
<<

{$(WIN_DIR)}.c{$(TMP_DIR)}.obj::







|







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
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_IO_FAILURE 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.
 *







|







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
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_IO_FAILURE;
    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.







|







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
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_IO_FAILURE is returned.
 *
 * Side effects:
 *	None.
 *
 *--------------------------------------------------------------------------
 */








|







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
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_IO_FAILURE;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpCreateProcess --
 *







|







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 --
 *