Tcl Source Code

Check-in [709a7deb31]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:changed tests to use "tcltest" namespace instead of "test". added constraints to tests, rather than skipping the entire file.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-1-branch-old
Files: files | file ages | folders
SHA1: 709a7deb313ae249e9862eca4e03b3d7bc71ab7d
User & Date: hershey 1999-03-23 20:06:07
Context
1999-03-23
21:58
changed "test" namespace to "tcltest" check-in: f61f6d4d1d user: hershey tags: core-8-1-branch-old
20:06
changed tests to use "tcltest" namespace instead of "test". added constraints to tests, rather than ... check-in: 709a7deb31 user: hershey tags: core-8-1-branch-old
04:15
fixed some lint check-in: 9e78d9f280 user: stanton tags: core-8-1-branch-old
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to tests/README.

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
..
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
...
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
...
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
README -- Tcl test suite design document.

RCS: @(#) $Id: README,v 1.1.2.2 1999/03/11 18:49:22 hershey Exp $


Introduction:
-------------

This directory contains a set of validation tests for the Tcl
commands.  Each of the files whose name ends in ".test" is
intended to fully exercise one or a few Tcl commands.  The

commands tested by a given file are listed in the first line
of the file.

You can run the tests in three ways:

    (a) type "make test" in ../unix; this will run all of the tests.

    (b) type "tcltest <testFile> ?<option> <value>?






















    (c) start up tcltest in this directory, then "source" the test
        file (for example, type "source parse.test").  To run all
	of the tests, type "source all.tcl".

In all cases, no output will be generated if all goes well, except for
a listing of the tests..  If there are errors then additional messages
will appear in the format described below.  Note that some tests will
be skipped if you run as superuser.

This approach to testing was designed and initially implemented
by Mary Ann May-Pumphrey of Sun Microsystems.  Many thanks to
her for donating her work back to the public Tcl release.

The rest of this file provides additional information on the
features of the testing environment.


Definitions file:
-----------------
................................................................................
The file "defs.tcl" defines the "test" namespace which contains a
collection of procedures and variables used to run the tests.  It is
read in automatically by each of the .test files if needed, but once
it has been read once it will not be read again by the .test files.
Currently, the following procedures are exported from the "test"
namespace and automatically imported:

    cleanupTests dotests saveState restoreState normalizeMsg
    makeFile removeFile makeDirectory removeDirectory viewFile
    safeFetch bytestring set_iso8859_1_locale restore_locale
    setTmpDir

Please refer to the defs.tcl file for these procedures' specs.


To keep tests from polluting the current working directory with
unwanted files, you can specify a temporary directory, which will
become the current working directory for the tests, by specifying
-tmpdir on the command line or by calling the ::test::setTmpDir
procedure (after sourcing the defs.tcl file).  The default working dir
is the directory from which tcltest was called.  Please note that when
you run the test suite by calling "make test", the working dir is
<tcl8.1>/tests.


Test output:
------------

Foreach test file, the number of tests passed, skipped, and failed is
printed to stdout.  Aside from this statistical information, output
can be controlled on a per-test basis by the ::test::verbose variable.

::test::verbose can be set to any substring or permutation of "bps".


The default value of ::test::verbose is "b".  If 'b' is present, then
the entire test is printed for each failed test, otherwise only the
test's name, desired output, and actual output, are printed for each
failed test.  If 'p' is present, then a line is printed for each
passed test, otherwise no line is printed for passed tests.  If 's' is
present, then a line (containing the consraints taht cause the test to
be skipped) is printed for each skipped test, otherwise no line is
printed for skipped tests.

You can set ::test::verbose either interactively (after the defs.tcl
file has been sourced) or by the command line argument -verbose, for
example:

      tcltest socket.test -verbose "psb"


Selecting files to be sourced by all.tcl:
-----------------------------------------

You can specify the files you want all.tcl to source on the command
line with the -file options.  For example, if you call the
following:

     tcltest all.tcl -file unix*.test

all files in <tcl8.1>/tests that match the pattern unix*.test will be
sourced by the all.tcl file.  Another useful example is if a
particular test hangs, say "get.test", and you just want to run the
remaining tests, then you can call the following:

     tcltest all.tcl -file [h-z]*.test

Note that the argument to -file will be substituted relative to the
directory containing this file.


Selecting tests for execution within a file:
--------------------------------------------

Normally, all the tests in a file are run whenever the file is
sourced.  Each test will be skipped if it doesn't match (using glob
sytle matching) any element in the ::test::matchingTests variable, if





it matches (using glob sytle matching) an element in
::test::skippingTests, or if one of the elements of "constraints"
turns out not to be true.


You can set ::test::matchingTests and/or ::test::skippingTests either




interactively (after the defs.tcl file has been sourced), or by the
command line arguments -match and -skip, for example:

       tcltest socket.test -match "*2.* *4.*" -skip "*2.33*"

The three constraints: notIfCompiled, knownBug, and nonPortable can be
overridden either interactively (after the defs.tcl file has been
sourced) by setting the ::test::testConfig(<constraint>) variable, or
by using the -constraints command line option with the name of the
constraint in the argument.  The following example shows how to run
tests that are constrained by the knownBug and nonPortable
restricions:

	tcltest all.tcl -constraints "knownBug nonPortable"

................................................................................
and adding new ones.

Adding a New Test File:
-----------------------

If the file matches the tests/*.test pattern (as it should), then it
will automatically be run by the all.tcl file.  Make sure your test
file can be run from any working dir.  Running the following should
work the same from any cwd:

	tcltest <Tcl8.1>/tests/all.tcl

Make sure no temporary files are left behind by your test file.  Your
test file should call "::test::cleanupTests" before returning.  The
::test::cleanupTests procedure prints statistics about the number of
tests that passed, skipped, and failed, and removes all files the were
created using the ::test::makeFile and ::test::makeDirectory
procedures.

Be sure your tests can run cross-platform in both the build
environment as well as the installation environment.  If your test
file contains tests that should not be run in or more of those cases,
please use the constraints mechanism described in the next section to
skip those tests.
................................................................................

For white-box (regression) tests, the target should be the name of the
c function or Tcl procedure being tested.  For black-box tests, the
target should be the name of the feature being tested.  Related tests
should share a major number.

If your test requires that a file be created on the fly, please use
the ::test::makeFile procedure.  If your test requires that a small
file (<50 lines) be checked in, please consider creating the file on
the fly using the ::test::makeFile procedure.  Files created by the
::test::makeFile procedure will automatically be removed by the
::test::cleanupTests call at the end of each test file.

Add appropriate constraints (e.g., unixOnly) to any tests that should
not always be run.  For example, a test that should only be run on
Unix should look like the following:

    test getAttribute-1.1 {testing file permissions} {unixOnly} {
        lindex [file attributes foo.tcl] 5
    } {00644}

See the defs.tcl file for a list of built-in flags.  You can add any
constraints that you need.  The following is how the defs.tcl file


adds the "unixOnly" constraint:







    set ::test::testConfig(unixOnly) [expr {$tcl_platform(platform) == "unix"}]





































































Saving keystrokes:
------------------

A convenience procedure named "::test::dotests" is included in file
"defs.tcl".  It takes two arguments--the name of the test file (such
as "parse.test"), and a pattern selecting the tests you want to
execute.  It sets ::test::matching to the second argument, calls
"source" on the file specified in the first argument, and restores
::test::matching to its pre-call value at the end.


Incompatibilities with prior Tcl versions:
------------------------------------------

1) Global variables such as VERBOSE, TESTS, and testConfig are now
   renamed to use the new "test" namespace.

   old name   new name
   --------   --------
   VERBOSE    ::test::verbose
   TESTS      ::test::matchingTests
   testConfig ::test::testConfig

   The introduction of the "test" namespace is a precursor to using a
   "test" package.  This next step will be part of a future Tcl
   version.

2) VERBOSE values are no longer numeric.  Please see the section above
   on "Test output" for the new usage of the ::test::verbose variable.

3) When you run "make test", the working dir for the test suite is now
   the one from which you called "make test", rather than the
   <tcl8.1>/tests directory.  This change allows for both unix and
   windows test suites to be run simultaneously without interference.
   All tests must now run independently of their working directory.
   You can also control the working directory from the tcltest command
   line with the -tmpdir option.

|





|
|
|
>
|
|






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






|



|
|
|







 







|

|
<

|
>




|


|
|





|

|

|
>
>
|
|
|
|
|
|
|
|

|



|









|

|
|



|


|






|
|
>
>
>
>
>
|
<
<
>

<
>
>
>
>





|

|







 







|
|

|


|
|
|
|







 







|

|
|
|









|
|
>
>
|
>

>
>
>
>
>
|

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




|


|

|










|
|
|






|


|
|
|
|
|
|
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
..
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
...
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
...
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
README -- Tcl test suite design document.

RCS: @(#) $Id: README,v 1.1.2.3 1999/03/23 20:06:07 hershey Exp $


Introduction:
-------------

This directory contains a set of validation tests for the Tcl commands
and C Library procedures for Tcl.  Each of the files whose name ends
in ".test" is intended to fully exercise the functions in the C source
file that corresponds to the file prefix.  The C functions and/or Tcl
commands tested by a given file are listed in the first line of the
file.

You can run the tests in three ways:

    (a) type "make test" in ../unix; this will run all of the tests.

    (b) type "tcltest <testFile> ?<option> <value>?
	Command line options include:

	-verbose <level>     set the level of verbosity to a substirng
			     of "bps"

	-match <matchList>   only run tests that match one or more of
			     the glob patterns in <matchList>

	-skip <skipList>     do not run tests that match one or more
			     of the glob patterns in <skipList>

	-file <globPattern>  only source test files that match
			     <globPattern> (relative to the "tests"
			     directory).  This option onloy applies
			     when you run the test suite with the
			     "all.tcl" file.

	-constraints <list>  tests with any of the following two
			     constraints:  knownBug and nonPortable
			     that appear in <list> should not be
			     skipped.

    (c) start up tcltest in this directory, then "source" the test
        file (for example, type "source parse.test").  To run all
	of the tests, type "source all.tcl".

In all cases, no output will be generated if all goes well, except for
a listing of the tests.  If there are errors then additional messages
will appear in the format described below.  Note that some tests will
be skipped if you run as superuser.

This approach to testing was designed and initially implemented by
Mary Ann May-Pumphrey of Sun Microsystems in the early 1990's.  Many
thanks to her for donating her work back to the public Tcl release.

The rest of this file provides additional information on the
features of the testing environment.


Definitions file:
-----------------
................................................................................
The file "defs.tcl" defines the "test" namespace which contains a
collection of procedures and variables used to run the tests.  It is
read in automatically by each of the .test files if needed, but once
it has been read once it will not be read again by the .test files.
Currently, the following procedures are exported from the "test"
namespace and automatically imported:

    test cleanupTests dotests saveState restoreState normalizeMsg
    makeFile removeFile makeDirectory removeDirectory viewFile
    safeFetch bytestring set_iso8859_1_locale restore_locale setTmpDir


Please refer to the defs.tcl file for documentation on these
procedures.

To keep tests from polluting the current working directory with
unwanted files, you can specify a temporary directory, which will
become the current working directory for the tests, by specifying
-tmpdir on the command line or by calling the ::tcltest::setTmpDir
procedure (after sourcing the defs.tcl file).  The default working dir
is the directory from which tcltest was called.  Please note that when
you run the test suite by calling "make test", the working dir is no
longer automatically switched to "tests".


Test output:
------------

For each test file, the number of tests passed, skipped, and failed is
printed to stdout.  Aside from this statistical information, output
can be controlled on a per-test basis by the ::tcltest::verbose variable.

::tcltest::verbose can be set to any substring or permutation of "bps".
In the string "bps", the 'b' stands for a test's "body", the 'p'
stands for "passed" tests, and the 's' stands for "skipped" tests.
The default value of ::tcltest::verbose is "b".  If 'b' is present, then
the entire body of the test is printed for each failed test, otherwise
only the test's name, desired output, and actual output, are printed
for each failed test.  If 'p' is present, then a line is printed for
each passed test, otherwise no line is printed for passed tests.  If
's' is present, then a line (containing the consraints that cause the
test to be skipped) is printed for each skipped test, otherwise no
line is printed for skipped tests.

You can set ::tcltest::verbose either interactively (after the defs.tcl
file has been sourced) or by the command line argument -verbose, for
example:

      tcltest socket.test -verbose bps


Selecting files to be sourced by all.tcl:
-----------------------------------------

You can specify the files you want all.tcl to source on the command
line with the -file options.  For example, if you call the
following:

     tcltest all.tcl -file "unix*.test"

all files in "tests" directory that match the pattern unix*.test will
be sourced by the all.tcl file.  Another useful example is if a
particular test hangs, say "get.test", and you just want to run the
remaining tests, then you can call the following:

     tcltest all.tcl -file "[h-z]*.test"

Note that the argument to -file will be substituted relative to the
"tests" directory.


Selecting tests for execution within a file:
--------------------------------------------

Normally, all the tests in a file are run whenever the file is
sourced.  An individual test will be skipped if one of the following
conditions is met:

    1) the "name" of the tests does not match (using glob style
       matching) one or more elements in the ::tcltest::matchingTests
       variable

    2) the "name" of the tests matches (using glob style matching) one


       or more elements in the ::tcltest::skippingTests variable


    3) the "constraints" argument to the "test" call, if given,
       contains one or more false elements.

You can set ::tcltest::matchingTests and/or ::tcltest::skippingTests either
interactively (after the defs.tcl file has been sourced), or by the
command line arguments -match and -skip, for example:

       tcltest socket.test -match "*2.* *4.*" -skip "*2.33*"

The two predefined constraints (knownBug and nonPortable) can be
overridden either interactively (after the defs.tcl file has been
sourced) by setting the ::tcltest::testConfig(<constraint>) variable, or
by using the -constraints command line option with the name of the
constraint in the argument.  The following example shows how to run
tests that are constrained by the knownBug and nonPortable
restricions:

	tcltest all.tcl -constraints "knownBug nonPortable"

................................................................................
and adding new ones.

Adding a New Test File:
-----------------------

If the file matches the tests/*.test pattern (as it should), then it
will automatically be run by the all.tcl file.  Make sure your test
file can be run from any working directory by running the following
from several different working directories:

	tcltest tests/all.tcl

Make sure no temporary files are left behind by your test file.  Your
test file should call "::tcltest::cleanupTests" before returning.  The
::tcltest::cleanupTests procedure prints statistics about the number of
tests that passed, skipped, and failed, and removes all files that
were created using the ::tcltest::makeFile and ::tcltest::makeDirectory
procedures.

Be sure your tests can run cross-platform in both the build
environment as well as the installation environment.  If your test
file contains tests that should not be run in or more of those cases,
please use the constraints mechanism described in the next section to
skip those tests.
................................................................................

For white-box (regression) tests, the target should be the name of the
c function or Tcl procedure being tested.  For black-box tests, the
target should be the name of the feature being tested.  Related tests
should share a major number.

If your test requires that a file be created on the fly, please use
the ::tcltest::makeFile procedure.  If your test requires that a small
file (<50 lines) be checked in, please consider creating the file on
the fly using the ::tcltest::makeFile procedure.  Files created by the
::tcltest::makeFile procedure will automatically be removed by the
::tcltest::cleanupTests call at the end of each test file.

Add appropriate constraints (e.g., unixOnly) to any tests that should
not always be run.  For example, a test that should only be run on
Unix should look like the following:

    test getAttribute-1.1 {testing file permissions} {unixOnly} {
        lindex [file attributes foo.tcl] 5
    } {00644}

See the "Constraints" section for a list of built in
constraints and information on how to add your own constraints.


Constraints:
------------

Constraints are used to determine whether a test is run.  Each
constraint is stored as an index in the array ::tcltest::testConfig.  For
example, the unixOnly constraint is defined as the following:

    set ::tcltest::testConfig(unixOnly) \
	[expr {$tcl_platform(platform) == "unix"}]

If a test is constrained by "unixOnly", then it will only be run if
the value of ::tcltest::testConfig(unixOnly) is true.

The following is a list of constraints defined in the defs.tcl file:

unix            test can only be run on any UNIX platform
pc	        test can only be run on any Windows platform
nt	        test can only be run on any Windows NT platform
95	        test can only be run on any Windows 95 platform
mac	        test can only be run on any Mac platform
unixOrPc        test can only be run on a UNIX or PC platform
macOrPc	        test can only be run on a Mac or PC platform
macOrUnix       test can only be run on a Mac or UNIX platform
tempNotPc	test can not be run on Windows.  This flag is used
		to temporarily disable a test.
tempNotMac	test can not be run on a Mac.  This flag is used
		to temporarily disable a test.
unixCrash       test crashes if it's run on UNIX.  This flag is used
		to temporarily disable a test.
pcCrash 	test crashes if it's run on Windows.  This flag is
		used to temporarily disable a test.
macCrash 	test crashes if it's run on a Mac.  This flag is used
		to temporarily disable a test.

nonPortable	test can only be run in the master Tcl/Tk
		development environment.  Some tests are inherently
		non-portable because they depend on things like word
		length, file system configuration, window manager,
		etc.  These tests are only run in the main Tcl
		development directory where the configuration is
		well known.

interactive	test can only be run in if the interpreter is in
		interactive mode.


knownBug	test is known to fail and the bug is not yet
                fixed.  This constraint is always true.

emptyTest	test is empty, and so not worth running, but
                it remains as a place-holder for a test to be
                written in the future.  This constraint is always
                true.

nonBlockFiles	test can only be run if platform supports setting
		files into nonblocking mode

asyncPipeClose	test can only be run if platform supports async
		flush and async close on a pipe

unixExecs	test can only be run if this machine has commands
		such as 'cat', 'echo' etc available.

hasIsoLocale	test can only be run if can switch to an iso locale

fonts		test can only be run if the wish app's fonts can
		be controlled by Tk.

root		test can only run if Unix user is root
notRoot		test can only run if Unix user is not root

eformat		test can only run if app has a working version of
		sprintf with respect to the "e" format of
		floating-point numbers.

stdio		test can only be run if the current app can be
		spawned via a pipe

Saving keystrokes:
------------------

A convenience procedure named "::tcltest::dotests" is included in file
"defs.tcl".  It takes two arguments--the name of the test file (such
as "parse.test"), and a pattern selecting the tests you want to
execute.  It sets ::tcltest::matching to the second argument, calls
"source" on the file specified in the first argument, and restores
::tcltest::matching to its pre-call value at the end.


Incompatibilities with prior Tcl versions:
------------------------------------------

1) Global variables such as VERBOSE, TESTS, and testConfig are now
   renamed to use the new "test" namespace.

   old name   new name
   --------   --------
   VERBOSE    ::tcltest::verbose
   TESTS      ::tcltest::matchingTests
   testConfig ::tcltest::testConfig

   The introduction of the "test" namespace is a precursor to using a
   "test" package.  This next step will be part of a future Tcl
   version.

2) VERBOSE values are no longer numeric.  Please see the section above
   on "Test output" for the new usage of the ::tcltest::verbose variable.

3) When you run "make test", the working dir for the test suite is now
   the one from which you called "make test", rather than the "tests"
   directory.  This change allows for both unix and windows test
   suites to be run simultaneously without interference.  All tests
   must now run independently of their working directory.  You can
   also control the working directory from the tcltest command line
   with the -tmpdir option.

Changes to tests/all.tcl.

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
..
60
61
62
63
64
65
66
67
68










# 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.
# All rights reserved.
# 
# RCS: @(#) $Id: all.tcl,v 1.1.2.3 1999/03/12 19:51:30 hershey Exp $

if {[lsearch ::test [namespace children]] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}
set ::test::testSingleFile false

puts stdout "Tcl 8.1 tests running in interp:  [info nameofexecutable]"
puts stdout "Tests running in working dir:  $::test::tmpDir"
if {[llength $::test::skippingTests] > 0} {
    puts stdout "Skipping tests that match:  $::test::skippingTests"
}
if {[llength $::test::matchingTests] > 0} {
    puts stdout "Only running tests that match:  $::test::matchingTests"
}

# Use command line specified glob pattern (specified by -file or -f)
# if one exists.  Otherwise use *.test (or *.tes on win32s).  If given,
# the file pattern should be specified relative to the dir containing
# this file.  If no files are found to match the pattern, print an
# error message and exit.
set fileIndex [expr {[lsearch $argv "-file"] + 1}]
set fIndex [expr {[lsearch $argv "-f"] + 1}]
if {($fileIndex < 1) || ($fIndex > $fileIndex)} {
    set fileIndex $fIndex
}
if {$fileIndex > 0} {
    set globPattern [file join $::test::testsDir [lindex $argv $fileIndex]]
    puts stdout "Sourcing files that match:  $globPattern"
} elseif {$tcl_platform(os) == "Win32s"} {
    set globPattern [file join $::test::testsDir *.tes]
} else {
    set globPattern [file join $::test::testsDir *.test]
}
set fileList [glob -nocomplain $globPattern]
if {[llength $fileList] < 1} {
    puts "Error: no files found matching $globPattern"
    exit
}
set timeCmd {clock format [clock seconds]}
................................................................................
    if {[catch {source $file} msg]} {
	puts stdout $msg
    }
}

# cleanup
puts stdout "\nTests ended at [eval $timeCmd]"
::test::cleanupTests 1
return
















|

|


|

|
|
|
|

|
|



|
|
|
<






|

<
<

|







 







|

>
>
>
>
>
>
>
>
>
>
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
..
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
# 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.
# All rights reserved.
# 
# RCS: @(#) $Id: all.tcl,v 1.1.2.4 1999/03/23 20:06:08 hershey Exp $

if {[lsearch ::tcltest [namespace children]] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}
set ::tcltest::testSingleFile false

puts stdout "Tcl $tcl_patchLevel tests running in interp:  [info nameofexecutable]"
puts stdout "Tests running in working dir:  $::tcltest::tmpDir"
if {[llength $::tcltest::skippingTests] > 0} {
    puts stdout "Skipping tests that match:  $::tcltest::skippingTests"
}
if {[llength $::tcltest::matchingTests] > 0} {
    puts stdout "Only running tests that match:  $::tcltest::matchingTests"
}

# Use command line specified glob pattern (specified by -file or -f)
# if one exists.  Otherwise use *.test.  If given, the file pattern
# should be specified relative to the dir containing this file.  If no
# files are found to match the pattern, print an error message and exit.

set fileIndex [expr {[lsearch $argv "-file"] + 1}]
set fIndex [expr {[lsearch $argv "-f"] + 1}]
if {($fileIndex < 1) || ($fIndex > $fileIndex)} {
    set fileIndex $fIndex
}
if {$fileIndex > 0} {
    set globPattern [file join $::tcltest::testsDir [lindex $argv $fileIndex]]
    puts stdout "Sourcing files that match:  $globPattern"


} else {
    set globPattern [file join $::tcltest::testsDir *.test]
}
set fileList [glob -nocomplain $globPattern]
if {[llength $fileList] < 1} {
    puts "Error: no files found matching $globPattern"
    exit
}
set timeCmd {clock format [clock seconds]}
................................................................................
    if {[catch {source $file} msg]} {
	puts stdout $msg
    }
}

# cleanup
puts stdout "\nTests ended at [eval $timeCmd]"
::tcltest::cleanupTests 1
return










Changes to tests/append.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
174
175
176
177
178
179
180
181
182
183










# 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.
#
# RCS: @(#) $Id: append.test,v 1.1.2.3 1999/03/11 18:49:23 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}
catch {unset x}

test append-1.1 {append command} {
    catch {unset x}
    list [append x 1 2 abc "long string"] $x
................................................................................
} {0 1 {can't read "x": no such variable}}

catch {unset i x result y}
catch {rename foo ""}
catch {rename check ""}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
# 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.
#
# RCS: @(#) $Id: append.test,v 1.1.2.4 1999/03/23 20:06:08 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}
catch {unset x}

test append-1.1 {append command} {
    catch {unset x}
    list [append x 1 2 abc "long string"] $x
................................................................................
} {0 1 {can't read "x": no such variable}}

catch {unset i x result y}
catch {rename foo ""}
catch {rename check ""}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/assocd.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
..
56
57
58
59
60
61
62
63
64
65










# 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.
#
# RCS: @(#) $Id: assocd.test,v 1.1.2.3 1999/03/11 18:49:23 hershey Exp $

if {[string compare testsetassocdata [info commands testsetassocdata]] != 0} {
    puts "This application hasn't been compiled with the tests for assocData,"
    puts "therefore I am skipping all of these tests."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test assocd-1.1 {testing setting assoc data} {
   testsetassocdata a 1
} ""
test assocd-1.2 {testing setting assoc data} {
................................................................................
   testdelassocdata 123
} ""
test assocd-3.3 {testing deleting assoc data} {
   list [catch {testdelassocdata nonexistent} msg] $msg
} {0 {}}

# cleanup
::test::cleanupTests
return

















|







|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
..
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
# 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.
#
# RCS: @(#) $Id: assocd.test,v 1.1.2.4 1999/03/23 20:06:08 hershey Exp $

if {[string compare testsetassocdata [info commands testsetassocdata]] != 0} {
    puts "This application hasn't been compiled with the tests for assocData,"
    puts "therefore I am skipping all of these tests."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test assocd-1.1 {testing setting assoc data} {
   testsetassocdata a 1
} ""
test assocd-1.2 {testing setting assoc data} {
................................................................................
   testdelassocdata 123
} ""
test assocd-3.3 {testing deleting assoc data} {
   list [catch {testdelassocdata nonexistent} msg] $msg
} {0 {}}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/async.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
129
130
131
132
133
134
135
136
137
138










# 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.
#
# RCS: @(#) $Id: async.test,v 1.1.2.3 1999/03/11 18:49:23 hershey Exp $

if {[info commands testasync] == {}} {
    puts "This application hasn't been compiled with the \"testasync\""
    puts "command, so I can't test Tcl_AsyncCreate et al."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc async1 {result code} {
    global aresult acode
    set aresult $result
    set acode $code
................................................................................
test async-3.1 {deleting handlers} {
    set x {}
    list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
} {3 del2 {0 0 0 del1 del2}}

# cleanup
testasync delete
::test::cleanupTests
return

















|







|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
# 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.
#
# RCS: @(#) $Id: async.test,v 1.1.2.4 1999/03/23 20:06:09 hershey Exp $

if {[info commands testasync] == {}} {
    puts "This application hasn't been compiled with the \"testasync\""
    puts "command, so I can't test Tcl_AsyncCreate et al."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc async1 {result code} {
    global aresult acode
    set aresult $result
    set acode $code
................................................................................
test async-3.1 {deleting handlers} {
    set x {}
    list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
} {3 del2 {0 0 0 del1 del2}}

# cleanup
testasync delete
::tcltest::cleanupTests
return











Added tests/autoMkindex.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
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
# Test file for:
#   auto_mkindex
#
# This file provides example cases for testing the Tcl autoloading
# facility.  Things are much more complicated with namespaces and classes.
# The "auto_mkindex" facility can no longer be built on top of a simple
# regular expression parser.  It must recognize constructs like this:
#
#   namespace eval foo {
#       proc test {x y} { ... }
#       namespace eval bar {
#           proc another {args} { ... }
#       }
#   }
#
# Note that procedures and itcl class definitions can be nested inside
# of namespaces.
#
# Copyright (c) 1993-1998  Lucent Technologies, Inc.

# This shouldn't cause any problems
namespace import -force blt::*

# Should be able to handle "proc" definitions, even if they are
# preceded by white space.

proc normal {x y} {return [expr $x+$y]}
  proc indented {x y} {return [expr $x+$y]}

#
# Should be able to handle proc declarations within namespaces,
# even if they have explicit namespace paths.
#
namespace eval buried {
    proc inside {args} {return "inside: $args"}

    namespace export pub_*
    proc pub_one {args} {return "one: $args"}
    proc pub_two {args} {return "two: $args"}
}
proc buried::within {args} {return "within: $args"}

namespace eval buried {
    namespace eval under {
        proc neath {args} {return "neath: $args"}
    }
    namespace eval ::buried {
        proc relative {args} {return "relative: $args"}
        proc ::top {args} {return "top: $args"}
        proc ::buried::explicit {args} {return "explicit: $args"}
    }
}










Changes to tests/autoMkindex.test.

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
..
65
66
67
68
69
70
71
72
73










#
# 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.
#
# RCS: @(#) $Id: autoMkindex.test,v 1.1.2.3 1999/03/11 18:49:24 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# temporarily copy the autoMkindex.tcl file from testsDir to tmpDir
set origMkindexFile [file join $::test::testsDir autoMkindex.tcl]
set newMkindexFile [file join $::test::tmpDir autoMkindex.tcl]
if {![catch {file copy $origMkindexFile $newMkindexFile}]} {
    set removeAutoMkindex 1
}

test autoMkindex-1.1 {remove any existing tclIndex file} {
    file delete tclIndex
    file exists tclIndex
................................................................................
} "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two"

# cleanup
if {[info exists removeAutoMkindex]} {
    catch {file delete $newMkindexFile}
}
catch {file delete -force tclIndex}
::test::cleanupTests

















|

|




|
|







 







|

>
>
>
>
>
>
>
>
>
>
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
..
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
#
# 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.
#
# RCS: @(#) $Id: autoMkindex.test,v 1.1.2.4 1999/03/23 20:06:10 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# temporarily copy the autoMkindex.tcl file from testsDir to tmpDir
set origMkindexFile [file join $::tcltest::testsDir autoMkindex.tcl]
set newMkindexFile [file join $::tcltest::tmpDir autoMkindex.tcl]
if {![catch {file copy $origMkindexFile $newMkindexFile}]} {
    set removeAutoMkindex 1
}

test autoMkindex-1.1 {remove any existing tclIndex file} {
    file delete tclIndex
    file exists tclIndex
................................................................................
} "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two"

# cleanup
if {[info exists removeAutoMkindex]} {
    catch {file delete $newMkindexFile}
}
catch {file delete -force tclIndex}
::tcltest::cleanupTests











Changes to tests/basic.test.

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
...
525
526
527
528
529
530
531
532
533
534










#
# 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.
#
# RCS: @(#) $Id: basic.test,v 1.1.2.3 1999/03/11 18:49:24 hershey Exp $
#

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {namespace delete test_ns_basic}
catch {interp delete test_interp}
catch {rename p ""}
catch {rename q ""}
................................................................................
catch {namespace delete george}
catch {interp delete test_interp}
catch {rename p ""}
catch {rename q ""}
catch {rename cmd ""}
catch {rename value:at: ""}
catch {unset x}
::test::cleanupTests
return

















|


|







 







|


>
>
>
>
>
>
>
>
>
>
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
...
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
#
# 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.
#
# RCS: @(#) $Id: basic.test,v 1.1.2.4 1999/03/23 20:06:10 hershey Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {namespace delete test_ns_basic}
catch {interp delete test_interp}
catch {rename p ""}
catch {rename q ""}
................................................................................
catch {namespace delete george}
catch {interp delete test_interp}
catch {rename p ""}
catch {rename q ""}
catch {rename cmd ""}
catch {rename value:at: ""}
catch {unset x}
::tcltest::cleanupTests
return











Changes to tests/binary.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451










#
# 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.
#
# RCS: @(#) $Id: binary.test,v 1.1.2.3 1999/03/11 18:49:25 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test binary-1.1 {Tcl_BinaryObjCmd: bad args} {
    list [catch {binary} msg] $msg
} {1 {wrong # args: should be "binary option ?arg arg ...?"}}
test binary-1.2 {Tcl_BinaryObjCmd: bad args} {
................................................................................
} {2 1 1.6}
test binary-41.8 {ScanNumber: word alignment} {nonPortable pcOnly} {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2
} {2 1 1.6}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
#
# 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.
#
# RCS: @(#) $Id: binary.test,v 1.1.2.4 1999/03/23 20:06:10 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test binary-1.1 {Tcl_BinaryObjCmd: bad args} {
    list [catch {binary} msg] $msg
} {1 {wrong # args: should be "binary option ?arg arg ...?"}}
test binary-1.2 {Tcl_BinaryObjCmd: bad args} {
................................................................................
} {2 1 1.6}
test binary-41.8 {ScanNumber: word alignment} {nonPortable pcOnly} {
    catch {unset arg1; unset arg2}
    list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2
} {2 1 1.6}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/case.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
82
83
84
85
86
87
88
89
90
91










# 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.
#
# RCS: @(#) $Id: case.test,v 1.1.2.3 1999/03/11 18:49:25 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test case-1.1 {simple pattern} {
    case a in a {format 1} b {format 2} c {format 3} default {format 4}
} 1
test case-1.2 {simple pattern} {
................................................................................
    }
} {2}
test case-3.3 {single-argument form for pattern/command pairs} {
    list [catch {case z in {a 2 b}} msg] $msg
} {1 {extra case pattern with no body}}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
# 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.
#
# RCS: @(#) $Id: case.test,v 1.1.2.4 1999/03/23 20:06:11 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test case-1.1 {simple pattern} {
    case a in a {format 1} b {format 2} c {format 3} default {format 4}
} 1
test case-1.2 {simple pattern} {
................................................................................
    }
} {2}
test case-3.3 {single-argument form for pattern/command pairs} {
    list [catch {case z in {a 2 b}} msg] $msg
} {1 {extra case pattern with no body}}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/clock.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
205
206
207
208
209
210
211
212
213
214










#
# 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.
#
# RCS: @(#) $Id: clock.test,v 1.1.2.3 1999/03/11 18:49:26 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test clock-1.1 {clock tests} {
    list [catch {clock} msg] $msg
} {1 {wrong # args: should be "clock option ?arg ...?"}}
test clock-1.2 {clock tests} {
................................................................................
} {061}
test clock-6.11 {clock roll over dates} {
    set time [clock scan "March 1, 2001" -gmt true]
    clock format $time -format %j -gmt true
} {060}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
#
# 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.
#
# RCS: @(#) $Id: clock.test,v 1.1.2.4 1999/03/23 20:06:11 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test clock-1.1 {clock tests} {
    list [catch {clock} msg] $msg
} {1 {wrong # args: should be "clock option ?arg ...?"}}
test clock-1.2 {clock tests} {
................................................................................
} {061}
test clock-6.11 {clock roll over dates} {
    set time [clock scan "March 1, 2001" -gmt true]
    clock format $time -format %j -gmt true
} {060}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/cmdAH.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
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
....
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
....
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
....
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
....
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
....
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
....
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
....
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474










#
# 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.
#
# RCS: @(#) $Id: cmdAH.test,v 1.1.2.7 1999/03/11 18:49:26 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

global env
set cmdAHwd [pwd]
catch {set platform [testgetplatform]}

................................................................................
    list [catch {file readable a b} msg] $msg
} {1 {wrong # args: should be "file readable name"}}
testchmod 444 gorp.file
test cmdAH-16.2 {Tcl_FileObjCmd: readable} {
    file readable gorp.file
} 1
testchmod 333 gorp.file
test cmdAH-16.3 {Tcl_FileObjCmd: readable} {unixOnly && !root} {
    file reada gorp.file
} 0

# writable

test cmdAH-17.1 {Tcl_FileObjCmd: writable} {
    list [catch {file writable a b} msg] $msg
} {1 {wrong # args: should be "file writable name"}}
testchmod 555 gorp.file
test cmdAH-17.2 {Tcl_FileObjCmd: writable} {!root} {
    file writable gorp.file
} 0
testchmod 222 gorp.file
test cmdAH-17.3 {Tcl_FileObjCmd: writable} {
    file writable gorp.file
} 1

................................................................................

test cmdAH-18.1 {Tcl_FileObjCmd: executable} {
    list [catch {file executable a b} msg] $msg
} {1 {wrong # args: should be "file executable name"}}
test cmdAH-18.2 {Tcl_FileObjCmd: executable} {
    file executable gorp.file
} 0
test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix} {
    # Only on unix will setting the execute bit on a regular file
    # cause that file to be executable.   
    
    testchmod 775 gorp.file
    file exe gorp.file
} 1

test cmdAH-18.4 {Tcl_FileObjCmd: executable} {mac} {
    # On mac, the only executable files are of type APPL.

    set x [file exe gorp.file]    
    file attrib gorp.file -type APPL
    lappend x [file exe gorp.file]
} {0 1}
test cmdAH-18.5 {Tcl_FileObjCmd: executable} {pc} {
    # On pc, must be a .exe, .com, etc.
    
    set x [file exe gorp.file]
    makeFile foo gorp.exe
    lappend x [file exe gorp.exe]
    file delete gorp.exe
    set x
................................................................................
    catch {file nativename ~nOsUcHuSeR}
} 1

# The test below has to be done in /tmp rather than the current
# directory in order to guarantee (?) a local file system:  some
# NFS file systems won't do the stuff below correctly.

if {$tcl_platform(platform) == "unix"} {
    file delete /tmp/tcl.foo.dir/file
    removeDirectory /tmp/tcl.foo.dir
    makeDirectory /tmp/tcl.foo.dir
    makeFile 12345 /tmp/tcl.foo.dir/file
    exec chmod 000 /tmp/tcl.foo.dir
    if {$user != "root"} {
	test cmdAH-19.11 {Tcl_FileObjCmd: exists} {

	    file exists /tmp/tcl.foo.dir/file
	} 0
    }
    exec chmod 775 /tmp/tcl.foo.dir
    file delete /tmp/tcl.foo.dir/file
    removeDirectory /tmp/tcl.foo.dir

}

# Stat related commands

catch {testsetplatform $platform}
file delete gorp.file
makeFile "Test string" gorp.file
catch {exec chmod 765 gorp.file}
................................................................................

test cmdAH-25.1 {Tcl_FileObjCmd: owned} {
    list [catch {file owned a b} msg] $msg
} {1 {wrong # args: should be "file owned name"}}
test cmdAH-25.2 {Tcl_FileObjCmd: owned} {
    file owned gorp.file
} 1
test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unixOnly && !root} {
    file owned /
} 0

# readlink

test cmdAH-26.1 {Tcl_FileObjCmd: readlink} {
    list [catch {file readlink a b} msg] $msg
................................................................................
    lsort [array names stat]
} {atime ctime dev gid ino mode mtime nlink size type uid}
test cmdAH-28.4 {Tcl_FileObjCmd: stat} {
    catch {unset stat}
    file stat gorp.file stat
    list $stat(nlink) $stat(size) $stat(type)
} {1 12 file}
test cmdAH-28.5 {Tcl_FileObjCmd: stat} {unix} {
    catch {unset stat}
    file stat gorp.file stat
    expr $stat(mode)&0777
} {501}
test cmdAH-28.6 {Tcl_FileObjCmd: stat} {
    string tolower [list [catch {file stat _bogus_ stat} msg] \
	    $msg $errorCode]
................................................................................

    close [open foo.test w]
    file stat foo.test stat
    set x [expr {$stat(mode) > 0}]
    file delete foo.test
    set x
} 1
test cmdAH-28.9 {Tcl_FileObjCmd: stat} {pc} {
    # stat of root directory was failing.
    # don't care about answer, just that test runs.

    # relative paths that resolve to root
    set old [pwd]
    cd c:/
    file stat c: stat	    
................................................................................
    file stat . stat
    cd $old

    file stat / stat
    file stat c:/ stat
    file stat c:/. stat
} {}
test cmdAH-28.10 {Tcl_FileObjCmd: stat} {pc nonPortable} {
    # stat of root directory was failing.
    # don't care about answer, just that test runs.

    file stat //pop/$env(USERNAME) stat
    file stat //pop/$env(USERNAME)/ stat
    file stat //pop/$env(USERNAME)/. stat
} {}    
test cmdAH-28.11 {Tcl_FileObjCmd: stat} {pc nonPortable} {
    # stat of network directory was returning id of current local drive.

    set old [pwd]
    cd c:/

    file stat //pop/$env(USERNAME) stat
    cd $old
................................................................................
catch {exec chmod 777 dir.file}
file delete -force dir.file
file delete gorp.file
file delete link.file

cd $cmdAHwd

::test::cleanupTests
return


















|

|







 







|









|







 







|







|






|







 







|
|




<
<
>
|
<
|

|

>
|







 







|







 







|







 







|







 







|







|







 







|



>
>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
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
....
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
....
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
....
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
....
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
....
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
....
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
....
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
#
# 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.
#
# RCS: @(#) $Id: cmdAH.test,v 1.1.2.8 1999/03/23 20:06:12 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

global env
set cmdAHwd [pwd]
catch {set platform [testgetplatform]}

................................................................................
    list [catch {file readable a b} msg] $msg
} {1 {wrong # args: should be "file readable name"}}
testchmod 444 gorp.file
test cmdAH-16.2 {Tcl_FileObjCmd: readable} {
    file readable gorp.file
} 1
testchmod 333 gorp.file
test cmdAH-16.3 {Tcl_FileObjCmd: readable} {unixOnly notRoot} {
    file reada gorp.file
} 0

# writable

test cmdAH-17.1 {Tcl_FileObjCmd: writable} {
    list [catch {file writable a b} msg] $msg
} {1 {wrong # args: should be "file writable name"}}
testchmod 555 gorp.file
test cmdAH-17.2 {Tcl_FileObjCmd: writable} {notRoot} {
    file writable gorp.file
} 0
testchmod 222 gorp.file
test cmdAH-17.3 {Tcl_FileObjCmd: writable} {
    file writable gorp.file
} 1

................................................................................

test cmdAH-18.1 {Tcl_FileObjCmd: executable} {
    list [catch {file executable a b} msg] $msg
} {1 {wrong # args: should be "file executable name"}}
test cmdAH-18.2 {Tcl_FileObjCmd: executable} {
    file executable gorp.file
} 0
test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unixOnly} {
    # Only on unix will setting the execute bit on a regular file
    # cause that file to be executable.   
    
    testchmod 775 gorp.file
    file exe gorp.file
} 1

test cmdAH-18.4 {Tcl_FileObjCmd: executable} {macOnly} {
    # On mac, the only executable files are of type APPL.

    set x [file exe gorp.file]    
    file attrib gorp.file -type APPL
    lappend x [file exe gorp.file]
} {0 1}
test cmdAH-18.5 {Tcl_FileObjCmd: executable} {pcOnly} {
    # On pc, must be a .exe, .com, etc.
    
    set x [file exe gorp.file]
    makeFile foo gorp.exe
    lappend x [file exe gorp.exe]
    file delete gorp.exe
    set x
................................................................................
    catch {file nativename ~nOsUcHuSeR}
} 1

# The test below has to be done in /tmp rather than the current
# directory in order to guarantee (?) a local file system:  some
# NFS file systems won't do the stuff below correctly.

test cmdAH-19.11 {Tcl_FileObjCmd: exists} {unixOnly notRoot} {
    removeFile /tmp/tcl.foo.dir/file
    removeDirectory /tmp/tcl.foo.dir
    makeDirectory /tmp/tcl.foo.dir
    makeFile 12345 /tmp/tcl.foo.dir/file
    exec chmod 000 /tmp/tcl.foo.dir



    set result [file exists /tmp/tcl.foo.dir/file]


    exec chmod 775 /tmp/tcl.foo.dir
    removeFile /tmp/tcl.foo.dir/file
    removeDirectory /tmp/tcl.foo.dir
    set result
} 0

# Stat related commands

catch {testsetplatform $platform}
file delete gorp.file
makeFile "Test string" gorp.file
catch {exec chmod 765 gorp.file}
................................................................................

test cmdAH-25.1 {Tcl_FileObjCmd: owned} {
    list [catch {file owned a b} msg] $msg
} {1 {wrong # args: should be "file owned name"}}
test cmdAH-25.2 {Tcl_FileObjCmd: owned} {
    file owned gorp.file
} 1
test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unixOnly notRoot} {
    file owned /
} 0

# readlink

test cmdAH-26.1 {Tcl_FileObjCmd: readlink} {
    list [catch {file readlink a b} msg] $msg
................................................................................
    lsort [array names stat]
} {atime ctime dev gid ino mode mtime nlink size type uid}
test cmdAH-28.4 {Tcl_FileObjCmd: stat} {
    catch {unset stat}
    file stat gorp.file stat
    list $stat(nlink) $stat(size) $stat(type)
} {1 12 file}
test cmdAH-28.5 {Tcl_FileObjCmd: stat} {unixOnly} {
    catch {unset stat}
    file stat gorp.file stat
    expr $stat(mode)&0777
} {501}
test cmdAH-28.6 {Tcl_FileObjCmd: stat} {
    string tolower [list [catch {file stat _bogus_ stat} msg] \
	    $msg $errorCode]
................................................................................

    close [open foo.test w]
    file stat foo.test stat
    set x [expr {$stat(mode) > 0}]
    file delete foo.test
    set x
} 1
test cmdAH-28.9 {Tcl_FileObjCmd: stat} {pcOnly} {
    # stat of root directory was failing.
    # don't care about answer, just that test runs.

    # relative paths that resolve to root
    set old [pwd]
    cd c:/
    file stat c: stat	    
................................................................................
    file stat . stat
    cd $old

    file stat / stat
    file stat c:/ stat
    file stat c:/. stat
} {}
test cmdAH-28.10 {Tcl_FileObjCmd: stat} {pcOnly nonPortable} {
    # stat of root directory was failing.
    # don't care about answer, just that test runs.

    file stat //pop/$env(USERNAME) stat
    file stat //pop/$env(USERNAME)/ stat
    file stat //pop/$env(USERNAME)/. stat
} {}    
test cmdAH-28.11 {Tcl_FileObjCmd: stat} {pcOnly nonPortable} {
    # stat of network directory was returning id of current local drive.

    set old [pwd]
    cd c:/

    file stat //pop/$env(USERNAME) stat
    cd $old
................................................................................
catch {exec chmod 777 dir.file}
file delete -force dir.file
file delete gorp.file
file delete link.file

cd $cmdAHwd

::tcltest::cleanupTests
return












Changes to tests/cmdIL.test.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
...
305
306
307
308
309
310
311
312
313
314










#
# 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.
#
# RCS: @(#) $Id: cmdIL.test,v 1.1.2.4 1999/03/11 18:49:27 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test cmdIL-1.1 {Tcl_LsortObjCmd procedure} {
    list [catch {lsort} msg] $msg
} {1 {wrong # args: should be "lsort ?options? list"}}
test cmdIL-1.2 {Tcl_LsortObjCmd procedure} {
................................................................................
test cmdIL-4.22 {DictionaryCompare procedure, case} {
    lsort -dictionary {ABcd aBCd}
} {ABcd aBCd}
test cmdIL-4.23 {DictionaryCompare procedure, case} {
    lsort -dictionary {ABcd AbCd}
} {ABcd AbCd}
test cmdIL-4.24 {DictionaryCompare procedure, international characters} {hasIsoLocale} {
    ::test::set_iso8859_1_locale
    set result [lsort -dictionary "a b c A B C \xe3 \xc4"]
    ::test::restore_locale
    set result
} "A a B b C c \xe3 \xc4"
test cmdIL-4.25 {DictionaryCompare procedure, international characters} {hasIsoLocale} {
    ::test::set_iso8859_1_locale
    set result [lsort -dictionary "a23\xe3 a23\xc5 a23\xe4"]
    ::test::restore_locale
    set result
} "a23\xe3 a23\xe4 a23\xc5"
test cmdIL-4.26 {DefaultCompare procedure, signed characters} {
    set l [lsort [list "abc\200" "abc"]]
    set viewlist {}
    foreach s $l {
	set viewelem ""
................................................................................
	}
	lappend viewlist $viewelem
    }
    set viewlist
} [list "abc" "abc\\200"]

# cleanup
::test::cleanupTests
return

















|

|







 







|

|



|

|







 







|


>
>
>
>
>
>
>
>
>
>
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
...
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
#
# 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.
#
# RCS: @(#) $Id: cmdIL.test,v 1.1.2.5 1999/03/23 20:06:13 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test cmdIL-1.1 {Tcl_LsortObjCmd procedure} {
    list [catch {lsort} msg] $msg
} {1 {wrong # args: should be "lsort ?options? list"}}
test cmdIL-1.2 {Tcl_LsortObjCmd procedure} {
................................................................................
test cmdIL-4.22 {DictionaryCompare procedure, case} {
    lsort -dictionary {ABcd aBCd}
} {ABcd aBCd}
test cmdIL-4.23 {DictionaryCompare procedure, case} {
    lsort -dictionary {ABcd AbCd}
} {ABcd AbCd}
test cmdIL-4.24 {DictionaryCompare procedure, international characters} {hasIsoLocale} {
    ::tcltest::set_iso8859_1_locale
    set result [lsort -dictionary "a b c A B C \xe3 \xc4"]
    ::tcltest::restore_locale
    set result
} "A a B b C c \xe3 \xc4"
test cmdIL-4.25 {DictionaryCompare procedure, international characters} {hasIsoLocale} {
    ::tcltest::set_iso8859_1_locale
    set result [lsort -dictionary "a23\xe3 a23\xc5 a23\xe4"]
    ::tcltest::restore_locale
    set result
} "a23\xe3 a23\xe4 a23\xc5"
test cmdIL-4.26 {DefaultCompare procedure, signed characters} {
    set l [lsort [list "abc\200" "abc"]]
    set viewlist {}
    foreach s $l {
	set viewelem ""
................................................................................
	}
	lappend viewlist $viewelem
    }
    set viewlist
} [list "abc" "abc\\200"]

# cleanup
::tcltest::cleanupTests
return











Changes to tests/cmdInfo.test.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
..
95
96
97
98
99
100
101
102
103
104










# 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.
#
# RCS: @(#) $Id: cmdInfo.test,v 1.1.2.3 1999/03/11 18:49:27 hershey Exp $

if {[info commands testcmdinfo] == {}} {
    puts "This application hasn't been compiled with the \"testcmdinfo\""
    puts "command, so I can't test Tcl_GetCommandInfo etc."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test cmdinfo-1.1 {command procedure and clientData} {
    testcmdinfo create x1
    testcmdinfo get x1
} {CmdProc1 original CmdDelProc1 original :: stringProc}
................................................................................
    rename cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2
    eval lappend y [testcmdtoken name $x]
} {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2}

# cleanup
catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1}
catch {rename x1 ""}
::test::cleanupTests
return

















|







|







 







|


>
>
>
>
>
>
>
>
>
>
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
..
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
# 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.
#
# RCS: @(#) $Id: cmdInfo.test,v 1.1.2.4 1999/03/23 20:06:13 hershey Exp $

if {[info commands testcmdinfo] == {}} {
    puts "This application hasn't been compiled with the \"testcmdinfo\""
    puts "command, so I can't test Tcl_GetCommandInfo etc."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test cmdinfo-1.1 {command procedure and clientData} {
    testcmdinfo create x1
    testcmdinfo get x1
} {CmdProc1 original CmdDelProc1 original :: stringProc}
................................................................................
    rename cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2
    eval lappend y [testcmdtoken name $x]
} {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2}

# cleanup
catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1}
catch {rename x1 ""}
::tcltest::cleanupTests
return











Changes to tests/cmdMZ.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
560
561
562
563
564
565
566
567
568
569
570










# 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.
#
# RCS: @(#) $Id: cmdMZ.test,v 1.1.2.3 1999/03/11 18:49:28 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Tcl_PwdObjCmd

test cmdMZ-1.1 {Tcl_PwdObjCmd} {
    list [catch {pwd a} msg] $msg
................................................................................
# The tests for Tcl_SubstObjCmd are in subst.test
# The tests for Tcl_SwitchObjCmd are in switch.test
# There are no tests for Tcl_TimeObjCmd
# The tests for Tcl_TraceObjCmd and TraceVarProc are in trace.test
# The tests for Tcl_WhileObjCmd are in while.test

# cleanup
::test::cleanupTests
return


















|

|







 







|



>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
# 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.
#
# RCS: @(#) $Id: cmdMZ.test,v 1.1.2.4 1999/03/23 20:06:14 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Tcl_PwdObjCmd

test cmdMZ-1.1 {Tcl_PwdObjCmd} {
    list [catch {pwd a} msg] $msg
................................................................................
# The tests for Tcl_SubstObjCmd are in subst.test
# The tests for Tcl_SwitchObjCmd are in switch.test
# There are no tests for Tcl_TimeObjCmd
# The tests for Tcl_TraceObjCmd and TraceVarProc are in trace.test
# The tests for Tcl_WhileObjCmd are in while.test

# cleanup
::tcltest::cleanupTests
return












Changes to tests/compExpr-old.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
667
668
669
670
671
672
673
674
675
676










#
# 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.
#
# RCS: @(#) $Id: compExpr-old.test,v 1.1.2.2 1999/03/11 18:49:28 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    set gotT1 0
    puts "This application hasn't been compiled with the \"T1\" and"
    puts "\"T2\" math functions, so I'll skip some of the expr tests."
................................................................................
        set y  [expr round($x)]
    }
    p
} 3

# cleanup
unset a
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
#
# 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.
#
# RCS: @(#) $Id: compExpr-old.test,v 1.1.2.3 1999/03/23 20:06:14 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    set gotT1 0
    puts "This application hasn't been compiled with the \"T1\" and"
    puts "\"T2\" math functions, so I'll skip some of the expr tests."
................................................................................
        set y  [expr round($x)]
    }
    p
} 3

# cleanup
unset a
::tcltest::cleanupTests
return











Changes to tests/compExpr.test.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
320
321
322
323
324
325
326
327
328
329










#
# 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.
#
# RCS: @(#) $Id: compExpr.test,v 1.1.2.2 1999/03/11 18:49:29 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    set gotT1 0
    puts "This application hasn't been compiled with the \"T1\" and"
    puts "\"T2\" math functions, so I'll skip some of the expr tests."
................................................................................
test compExpr-6.1 {LogSyntaxError procedure, error in expr longer than 60 chars} {
    list [catch {expr {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1 foo 3} msg] $msg
} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012"}}

# cleanup
catch {unset a}
catch {unset b}
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
#
# 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.
#
# RCS: @(#) $Id: compExpr.test,v 1.1.2.3 1999/03/23 20:06:15 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    set gotT1 0
    puts "This application hasn't been compiled with the \"T1\" and"
    puts "\"T2\" math functions, so I'll skip some of the expr tests."
................................................................................
test compExpr-6.1 {LogSyntaxError procedure, error in expr longer than 60 chars} {
    list [catch {expr {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1 foo 3} msg] $msg
} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012"}}

# cleanup
catch {unset a}
catch {unset b}
::tcltest::cleanupTests
return











Changes to tests/compile.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
193
194
195
196
197
198
199
200
201
202
203










#
# 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.
#
# RCS: @(#) $Id: compile.test,v 1.1.2.4 1999/03/11 18:49:29 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# The following tests are very incomplete, although the rest of the
# test suite covers this file fairly well.

catch {rename p ""}
................................................................................

# cleanup
catch {rename p ""}
catch {namespace delete test_ns_compile}
catch {unset x}
catch {unset y}
catch {unset a}
::test::cleanupTests
return


















|

|







 







|



>
>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
#
# 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.
#
# RCS: @(#) $Id: compile.test,v 1.1.2.5 1999/03/23 20:06:15 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# The following tests are very incomplete, although the rest of the
# test suite covers this file fairly well.

catch {rename p ""}
................................................................................

# cleanup
catch {rename p ""}
catch {namespace delete test_ns_compile}
catch {unset x}
catch {unset y}
catch {unset a}
::tcltest::cleanupTests
return












Changes to tests/concat.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
45
46
47
48
49
50
51
52
53
54










# 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.
#
# RCS: @(#) $Id: concat.test,v 1.1.2.3 1999/03/11 18:49:29 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

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} {
................................................................................
    concat x y "  a b c	\n\t  " "   "  " def "
} {x y a b c def}
test concat-4.3 {pruning off extra white space sets length correctly} {
    llength [concat { {{a}} }]
} 1

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
# 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.
#
# RCS: @(#) $Id: concat.test,v 1.1.2.4 1999/03/23 20:06:16 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

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} {
................................................................................
    concat x y "  a b c	\n\t  " "   "  " def "
} {x y a b c def}
test concat-4.3 {pruning off extra white space sets length correctly} {
    llength [concat { {{a}} }]
} 1

# cleanup
::tcltest::cleanupTests
return











Changes to tests/dcall.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
..
39
40
41
42
43
44
45
46
47
48










# 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.
#
# RCS: @(#) $Id: dcall.test,v 1.1.2.3 1999/03/11 18:49:30 hershey Exp $

if {[info commands testdcall] == {}} {
    puts "This application hasn't been compiled with the \"testdcall\""
    puts "command, so I can't test Tcl_CallWhenDeleted."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test dcall-1.1 {deletion callbacks} {
    lsort -increasing [testdcall 1 2 3]
} {1 2 3}
test dcall-1.2 {deletion callbacks} {
................................................................................
    lsort -increasing [testdcall 20 21 22 -21]
} {20 22}
test dcall-1.6 {deletion callbacks} {
    lsort -increasing [testdcall 20 21 22 -21 -22 -20]
} {}

# cleanup
::test::cleanupTests
return

















|







|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
..
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
# 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.
#
# RCS: @(#) $Id: dcall.test,v 1.1.2.4 1999/03/23 20:06:16 hershey Exp $

if {[info commands testdcall] == {}} {
    puts "This application hasn't been compiled with the \"testdcall\""
    puts "command, so I can't test Tcl_CallWhenDeleted."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test dcall-1.1 {deletion callbacks} {
    lsort -increasing [testdcall 1 2 3]
} {1 2 3}
test dcall-1.2 {deletion callbacks} {
................................................................................
    lsort -increasing [testdcall 20 21 22 -21]
} {20 22}
test dcall-1.6 {deletion callbacks} {
    lsort -increasing [testdcall 20 21 22 -21 -22 -20]
} {}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/defs.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
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
..
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
...
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
...
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
...
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
...
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










# defs.tcl --
#
#	This file contains support code for the Tcl test suite.It is
#	It is normally sourced by the individual files in the test suite
#	before they run their tests.  This improved approach to testing
#	was designed and initially implemented by Mary Ann May-Pumphrey
#	of Sun Microsystems.
#
# Copyright (c) 1990-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: defs.tcl,v 1.1.2.2 1999/03/12 19:51:30 hershey Exp $






# Ensure that we have a minimal auto_path so we don't pick up extra junk.
set auto_path [list [info library]]


# create the "test" namespace for all testing variables and procedures
namespace eval test {
    foreach proc [list test cleanupTests dotests saveState restoreState \
	    normalizeMsg makeFile removeFile makeDirectory removeDirectory \
	    viewFile safeFetch bytestring set_iso8859_1_locale restore_locale \
	    setTmpDir] {




	namespace export $proc
    }

    # ::test::verbose defaults to "b"
    variable verbose "b"

    # matchingTests defaults to the empty list
    variable matchingTests {}

    # skippingTests defaults to the empty list
    variable skippingTests {}

    # Tests should not rely on the current working directory.
    # Files that are part of the test suite should be accessed relative to
    # ::test::testsDir.

    set originalDir [pwd]
    set tDir [file join $originalDir [file dirname [info script]]]
    cd $tDir
    variable testsDir [pwd]
    cd $originalDir

................................................................................

    variable numTestFiles 0
    variable testSingleFile true
    variable currentFailure false
    variable failFiles {}

    # Tests should remove all files they create.  The test suite will
    # check tmpDir for files created by the tests.  ::test::filesMade
    # keeps track of such files created using the test::makeFile and
    # test::makeDirectory procedures.  ::test::filesExisted stores
    # the names of pre-existing files.

    variable filesMade {}
    variable filesExisted {}

    # initialize ::test::numTests array to keep track fo the number of
    # tests that pass, fial, and are skipped.
    array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
}





# If there is no "memory" command (because memory debugging isn't
# enabled), generate a dummy command that does nothing.

if {[info commands memory] == ""} {
    proc memory args {}
}























































































































































































































# ::test::setTmpDir --
#
#	Set the ::test::tmpDir to the specified value.  If the path
#	is relative, make it absolute.  If the file exists but is not
#	a dir, then return an error.  If the dir does not already
#	exist, create it.  If you cannot create it, then return an error.
#
# Arguments:
#	value	the new value of ::test::tmpDir
#
# Results:
#	::test::tmpDir is set to <value> and created if it didn't already
#	exist.  The working dir is changed to ::test::tmpDir.

proc ::test::setTmpDir {value} {

    set ::test::tmpDir $value

    if {[string compare [file pathtype $::test::tmpDir] absolute] != 0} {
	set ::test::tmpDir [file join [pwd] $::test::tmpDir]
    }
    if {[file exists $::test::tmpDir]} {
	if {![file isdir $::test::tmpDir]} {
	    puts stderr "Error:  bad argument \"$value\" to -tmpdir:"
	    puts stderr "            \"$::test::tmpDir\""
	    puts stderr "        is not a directory"
	    exit
	}
    } else {
	file mkdir $::test::tmpDir
    }

    # change the working dir to tmpDir and add the existing files in
    # tmpDir to the filesExisted list.
    cd $::test::tmpDir
    foreach file [glob -nocomplain [file join [pwd] *]] {
	lappend ::test::filesExisted $file
    }
}

# ::test::processCmdLineArgs --
#
#	Use command line args to set the tmpDir, verbose, skippingTests, and
#	matchingTests variables.
#
# Arguments:
#	none
#
# Results:
#	::test::verbose is set to <value>

proc ::test::processCmdLineArgs {} {
    global argv

    # The "argv" var doesn't exist in some cases, so use {}
    # The "argv" var doesn't exist in some cases.
    if {(![info exists argv]) || ([llength $argv] < 2)} {
	set flagArray {}
    } else {
................................................................................
    if {[catch {array set flag $flagArray}]} {
	puts stderr "Error:  odd number of command line args specified:"
	puts stderr "        $argv"
	exit
    }
    
    # Allow for 1-char abbreviations, where applicable (e.g., -tmpdir == -t).


    foreach arg {-verbose -match -skip -constraints -tmpdir} {
	set abbrev [string range $arg 0 1]
	if {([info exists flag($abbrev)]) && \
		([lsearch $flagArray $arg] < [lsearch $flagArray $abbrev])} {
	    set flag($arg) $flag($abbrev)
	}
    }

    # Set ::test::tmpDir to the arg of the -tmpdir flag, if given.
    # ::test::tmpDir defaults to [pwd].
    # Save the names of files that already exist in ::test::tmpDir.
    if {[info exists flag(-tmpdir)]} {
	::test::setTmpDir $flag(-tmpdir)
    } else {
	set ::test::tmpDir [pwd]
    }
    foreach file [glob -nocomplain [file join $::test::tmpDir *]] {
	lappend ::test::filesExisted [file tail $file]
    }

    # Set ::test::verbose to the arg of the -verbose flag, if given
    if {[info exists flag(-verbose)]} {
	set ::test::verbose $flag(-verbose)
    }

    # Set ::test::matchingTests to the arg of the -match flag, if given
    if {[info exists flag(-match)]} {
	set ::test::matchingTests $flag(-match)
    }

    # Set ::test::skippingTests to the arg of the -skip flag, if given
    if {[info exists flag(-skip)]} {
	set ::test::skippingTests $flag(-skip)
    }

    # Use the -constraints flag, if given, so turn on the following
    # constraints:  notIfCompiled, knownBug, nonPortable
    if {[info exists flag(-constraints)]} {
	set constrList $flag(-constraints)
    } else {
	set constrList {}
    }
    foreach elt [list notIfCompiled knownBug nonPortable] {

	set ::test::testConfig($elt) [expr {[lsearch $constrList $elt] != -1}]
    }
    if {$::test::testConfig(nonPortable) == 0} {
	puts "(will skip non-portable tests)"
    }
}
test::processCmdLineArgs


# Check configuration information that will determine which tests
# to run.  To do this, create an array ::test::testConfig.  Each element
# has a 0 or 1 value, and the following elements are defined:
#	unixOnly -	1 means this is a UNIX platform, so it's OK
#			to run tests that only work under UNIX.
#	macOnly -	1 means this is a Mac platform, so it's OK
#			to run tests that only work on Macs.
#	pcOnly -	1 means this is a PC platform, so it's OK to
#			run tests that only work on PCs.
#	unixOrPc -	1 means this is a UNIX or PC platform.
#	macOrPc -	1 means this is a Mac or PC platform.
#	macOrUnix -	1 means this is a Mac or UNIX platform.
#	notIfCompiled -	1 means this that it is safe to run tests that
#                       might fail if the bytecode compiler is used. This
#                       element is set to 1 if the -allComp flag was used.
#                       Normally, this element is 0 so that tests that
#                       fail with the bytecode compiler are skipped.
#			As of 11/2/96 these are the history tests since
#			they depend on accurate source location information.
#			You can run these tests by using the -constraint
#			command line option with "knownBug" in the argument
#			list.
#       knownBug -      The test is known to fail and the bug is not yet
#                       fixed. The test will be run only if the flag
#                       -allBuggy is used (intended for Tcl dev. group
#                       internal use only).  You can run these tests by
#			using the -constraint command line option with
#			"knownBug" in the argument list.
#	nonPortable -	1 means this the tests are being running in
#			the master Tcl/Tk development environment;
#			Some tests are inherently non-portable because
#			they depend on things like word length, file system
#			configuration, window manager, etc.  These tests
#			are only run in the main Tcl development directory
#			where the configuration is well known.  You can
#			run these tests by using the -constraint command
#			line option with "nonPortable" in the argument list.
#	tempNotPc -	The inverse of pcOnly.  This flag is used to
#			temporarily disable a test.
#	tempNotMac -	The inverse of macOnly.  This flag is used to
#			temporarily disable a test.
#	nonBlockFiles - 1 means this platform supports setting files into
#			nonblocking mode.
#	asyncPipeClose- 1 means this platform supports async flush and
#			async close on a pipe.
#	unixExecs     - 1 means this machine has commands such as 'cat',
#			'echo' etc available.
#       hasIsoLocale  - 1 means the tests that need to switch to an iso
#                       locale can be run.
#

catch {unset ::test::testConfig}

# The following trace procedure makes it so that we can safely refer to
# non-existent members of the ::test::testConfig array without causing an
# error.  Instead, reading a non-existent member will return 0.  This is
# necessary because tests are allowed to use constraint "X" without ensuring
# that ::test::testConfig("X") is defined.

trace variable ::test::testConfig r ::test::safeFetch

proc ::test::safeFetch {n1 n2 op} {
    if {($n2 != {}) && ([info exists ::test::testConfig($n2)] == 0)} {
	set ::test::testConfig($n2) 0
    }
}

set ::test::testConfig(unixOnly) 	[expr {$tcl_platform(platform) == "unix"}]
set ::test::testConfig(macOnly) 	[expr {$tcl_platform(platform) == "macintosh"}]
set ::test::testConfig(pcOnly)		[expr {$tcl_platform(platform) == "windows"}]

set ::test::testConfig(unix)		$::test::testConfig(unixOnly)
set ::test::testConfig(mac)		$::test::testConfig(macOnly)
set ::test::testConfig(pc)		$::test::testConfig(pcOnly)

set ::test::testConfig(unixOrPc)	[expr {$::test::testConfig(unix) || $::test::testConfig(pc)}]
set ::test::testConfig(macOrPc)		[expr {$::test::testConfig(mac) || $::test::testConfig(pc)}]
set ::test::testConfig(macOrUnix)	[expr {$::test::testConfig(mac) || $::test::testConfig(unix)}]

set ::test::testConfig(nt)		[expr {$tcl_platform(os) == "Windows NT"}]
set ::test::testConfig(95)		[expr {$tcl_platform(os) == "Windows 95"}]
set ::test::testConfig(win32s)		[expr {$tcl_platform(os) == "Win32s"}]

# The following config switches are used to mark tests that should work,
# but have been temporarily disabled on certain platforms because they don't
# and we haven't gotten around to fixing the underlying problem.

set ::test::testConfig(tempNotPc) 	[expr {!$::test::testConfig(pc)}]
set ::test::testConfig(tempNotMac) 	[expr {!$::test::testConfig(mac)}]
set ::test::testConfig(tempNotUnix)	[expr {!$::test::testConfig(unix)}]

# The following config switches are used to mark tests that crash on
# certain platforms, so that they can be reactivated again when the
# underlying problem is fixed.

set ::test::testConfig(pcCrash) 	[expr {!$::test::testConfig(pc)}]
set ::test::testConfig(macCrash) 	[expr {!$::test::testConfig(mac)}]
set ::test::testConfig(unixCrash)	[expr {!$::test::testConfig(unix)}]

if {[catch {set f [open defs r]}]} {
    set ::test::testConfig(nonBlockFiles) 1
} else {
    if {[catch {fconfigure $f -blocking off}] == 0} {
	set ::test::testConfig(nonBlockFiles) 1
    } else {
	set ::test::testConfig(nonBlockFiles) 0
    }
    close $f
}

# If tests are being run as root, issue a warning message and set a
# variable to prevent some tests from running at all.

set user {}
if {$tcl_platform(platform) == "unix"} {
    catch {set user [exec whoami]}
    if {$user == ""} {
        catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
    }
    if {$user == ""} {set user root}
    if {$user == "root"} {
        puts stdout "Warning: you're executing as root.  I'll have to"
        puts stdout "skip some of the tests, since they'll fail as root."
	set ::test::testConfig(root) 1
    }
}

# Test for SCO Unix - cannot run async flushing tests because a potential
# problem with select is apparently interfering. (Mark Diekhans).

if {$tcl_platform(platform) == "unix"} {
    if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
	set ::test::testConfig(asyncPipeClose) 0
    } else {
	set ::test::testConfig(asyncPipeClose) 1
    }
} else {
    set ::test::testConfig(asyncPipeClose) 1
}

# Test to see if we have a broken version of sprintf with respect to the
# "e" format of floating-point numbers.

set ::test::testConfig(eformat) 1
if {[string compare "[format %g 5e-5]" "5e-05"] != 0} {
    set ::test::testConfig(eformat) 0
    puts stdout "(will skip tests that depend on the \"e\" format of floating-point numbers)"
}

# Test to see if execed commands such as cat, echo, rm and so forth are
# present on this machine.

set ::test::testConfig(unixExecs) 1
if {$tcl_platform(platform) == "macintosh"} {
    set ::test::testConfig(unixExecs) 0
}
if {($::test::testConfig(unixExecs) == 1) && ($tcl_platform(platform) == "windows")} {
    if {[catch {exec cat defs}] == 1} {
	set ::test::testConfig(unixExecs) 0
    }
    if {($::test::testConfig(unixExecs) == 1) && ([catch {exec echo hello}] == 1)} {
	set ::test::testConfig(unixExecs) 0
    }
    if {($::test::testConfig(unixExecs) == 1) && \
		([catch {exec sh -c echo hello}] == 1)} {
	set ::test::testConfig(unixExecs) 0
    }
    if {($::test::testConfig(unixExecs) == 1) && ([catch {exec wc defs}] == 1)} {
	set ::test::testConfig(unixExecs) 0
    }
    if {$::test::testConfig(unixExecs) == 1} {
	exec echo hello > removeMe
        if {[catch {exec rm removeMe}] == 1} {
	    set ::test::testConfig(unixExecs) 0
	}
    }
    if {($::test::testConfig(unixExecs) == 1) && ([catch {exec sleep 1}] == 1)} {
	set ::test::testConfig(unixExecs) 0
    }
    if {($::test::testConfig(unixExecs) == 1) && \
		([catch {exec fgrep unixExecs defs}] == 1)} {
	set ::test::testConfig(unixExecs) 0
    }
    if {($::test::testConfig(unixExecs) == 1) && ([catch {exec ps}] == 1)} {
	set ::test::testConfig(unixExecs) 0
    }
    if {($::test::testConfig(unixExecs) == 1) && \
		([catch {exec echo abc > removeMe}] == 0) && \
		([catch {exec chmod 644 removeMe}] == 1) && \
		([catch {exec rm removeMe}] == 0)} {
	set ::test::testConfig(unixExecs) 0
    } else {
	catch {exec rm -f removeMe}
    }
    if {($::test::testConfig(unixExecs) == 1) && \
		([catch {exec mkdir removeMe}] == 1)} {
	set ::test::testConfig(unixExecs) 0
    } else {
	catch {exec rm -r removeMe}
    }
    if {$::test::testConfig(unixExecs) == 0} {
	puts "(will skip tests that depend on Unix-style executables)"
    }
}

# ::test::cleanupTests --
#
# Remove files and dirs created using the makeFile and makeDirectory
# commands since the last time this proc was invoked.
#
# Print the names of the files created without the makeFile command
# since the tests were invoked.
#
# Print the number tests (total, passed, failed, and skipped) since the
# tests were invoked.
#

proc ::test::cleanupTests {{all 0}} {
    # remove files and directories created by the tests
    foreach file $::test::filesMade {
	if {[file exists $file]} {
	    catch {file delete -force $file}
	}
    }

    set tail [file tail [info script]]
    if {$all || $::test::testSingleFile} {
	# print stats
	puts -nonewline stdout "$tail:"
	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
	    puts -nonewline stdout "\t$index\t$::test::numTests($index)"
	}
	puts stdout ""

	# print number test files sourced
	# print names of files that ran tests which failed
	if {$all} {
	    puts stdout "Sourced $::test::numTestFiles Test Files."
	    set ::test::numTestFiles 0
	    if {[llength $::test::failFiles] > 0} {
		puts stdout "Files with failing tests: $::test::failFiles"
		set ::test::failFiles {}
	    }
	}












	# report the names of files in ::test::tmpDir that were not pre-existing.
	set currentFiles {}
	foreach file [glob -nocomplain [file join $::test::tmpDir *]] {
	    lappend currentFiles [file tail $file]
	}
	set filesNew {}
	foreach file $currentFiles {
	    if {[lsearch $::test::filesExisted $file] == -1} {
		lappend filesNew $file
	    }
	}
	if {[llength $filesNew] > 0} {
	    puts stdout "Warning: created files:\t$filesNew"
	}

	# reset filesMade, filesExisted, and numTests
	set ::test::filesMade {}
	set ::test::filesExisted $currentFiles
	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
	    set ::test::numTests($index) 0






	}
    } else {
	# if we're deferring stat-reporting until all files are sourced,
	# then add current file to failFile list if any tests in this file
	# failed
	incr ::test::numTestFiles
	if {($::test::currentFailure) && \
		([lsearch $::test::failFiles $tail] == -1)} {
	    lappend ::test::failFiles $tail
	}
	set ::test::currentFailure false
    }
}


# test --
#
# This procedure runs a test and prints an error message if the test fails.
# If ::test::verbose has been set, it also prints a message even if the
# test succeeds.  The test will be skipped if it doesn't match the
# ::test::matchingTests variable, if it matches an element in
# ::test::skippingTests, or if one of the elements of "constraints" turns
# out not to be true.
#
# Arguments:
# name -		Name of test, in the form foo-1.2.
# description -		Short textual description of the test, to
#			help humans understand what it does.
# constraints -		A list of one or more keywords, each of
#			which must be the name of an element in
#			the array "::test::testConfig".  If any of these
#			elements is zero, the test is skipped.
#			This argument may be omitted.
# script -		Script to run to carry out the test.  It must
#			return a result that can be checked for
#			correctness.
# expectedAnswer -	Expected result from script.

proc ::test::test {name description script expectedAnswer args} {
    incr ::test::numTests(Total)

    # skip the test if it's name matches an element of skippingTests
    foreach pattern $::test::skippingTests {
	if {[string match $pattern $name]} {
	    incr ::test::numTests(Skipped)
	    return
	}
    }
    # skip the test if it's name doesn't match any element of matchingTests
    if {[llength $::test::matchingTests] > 0} {
	set ok 0
	foreach pattern $::test::matchingTests {
	    if {[string match $pattern $name]} {
		set ok 1
		break
	    }
        }
	if {!$ok} {
	    incr ::test::numTests(Skipped)
	    return
	}
    }
    set i [llength $args]
    if {$i == 0} {
	set constraints {}
    } elseif {$i == 1} {
................................................................................
	set doTest 0
	if {[string match {*[$\[]*} $constraints] != 0} {
	    # full expression, e.g. {$foo > [info tclversion]}

	    catch {set doTest [uplevel #0 expr $constraints]}
	} elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
	    # something like {a || b} should be turned into 
	    # $::test::testConfig(a) || $::test::testConfig(b).

 	    regsub -all {[.a-zA-Z0-9]+} $constraints {$::test::testConfig(&)} c
	    catch {set doTest [eval expr $c]}
	} else {
	    # just simple constraints such as {unixOnly fonts}.

	    set doTest 1
	    foreach constraint $constraints {
		if {![info exists ::test::testConfig($constraint)]
			|| !$::test::testConfig($constraint)} {
		    set doTest 0


		    break
		}
	    }
	}
	if {$doTest == 0} {
	    incr ::test::numTests(Skipped)
	    if {[string first s $::test::verbose] != -1} {
		puts stdout "++++ $name SKIPPED: $constraints"







	    }
	    return	
	}
    } else {
	error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
    }
    memory tag $name
    set code [catch {uplevel $script} actualAnswer]
    if {$code != 0 || [string compare $actualAnswer $expectedAnswer] != 0} {
	incr ::test::numTests(Failed)
	set ::test::currentFailure true
	if {[string first b $::test::verbose] == -1} {
	    set script ""
	}
	puts stdout "\n==== $name $description FAILED"
	if {$script != ""} {
	    puts stdout "==== Contents of test case:"
	    puts stdout $script
	}
................................................................................
	    }
	} else {
	    puts stdout "---- Result was:\n$actualAnswer"
	}
	puts stdout "---- Result should have been:\n$expectedAnswer"
	puts stdout "==== $name FAILED\n" 
    } else { 
	incr ::test::numTests(Passed)
	if {[string first p $::test::verbose] != -1} {
	    puts stdout "++++ $name PASSED"
	}
    }
}

proc ::test::dotests {file args} {
    set savedTests $::test::matchingTests
    set ::test::matchingTests $args
    source $file
    set ::test::matchingTests $savedTests
}

proc ::test::openfiles {} {
    if {[catch {testchannel open} result]} {
	return {}
    }
    return $result
}

proc ::test::leakfiles {old} {
    if {[catch {testchannel open} new]} {
        return {}
    }
    set leak {}
    foreach p $new {
    	if {[lsearch $old $p] < 0} {
	    lappend leak $p
	}
    }
    return $leak
}

set ::test::saveState {}

proc ::test::saveState {} {
    uplevel #0 {set ::test::saveState [list [info procs] [info vars]]}
}

proc ::test::restoreState {} {
    foreach p [info procs] {
	if {[lsearch [lindex $::test::saveState 0] $p] < 0} {
	    rename $p {}
	}
    }
    foreach p [uplevel #0 {info vars}] {
	if {[lsearch [lindex $::test::saveState 1] $p] < 0} {
	    uplevel #0 "unset $p"
	}
    }
}

proc ::test::normalizeMsg {msg} {
    regsub "\n$" [string tolower $msg] "" msg
    regsub -all "\n\n" $msg "\n" msg
    regsub -all "\n\}" $msg "\}" msg
    return $msg
}

# makeFile --
................................................................................
#
# Create a new file with the name <name>, and write <contents> to it.
#
# If this file hasn't been created via makeFile since the last time
# cleanupTests was called, add it to the $filesMade list, so it will
# be removed by the next call to cleanupTests.
#
proc ::test::makeFile {contents name} {
    set fd [open $name w]
    fconfigure $fd -translation lf
    if {[string index $contents [expr {[string length $contents] - 1}]] == "\n"} {
	puts -nonewline $fd $contents
    } else {
	puts $fd $contents
    }
    close $fd

    set fullName [file join [pwd] $name]
    if {[lsearch $::test::filesMade $fullName] == -1} {
	lappend ::test::filesMade $fullName
    }
}

proc ::test::removeFile {name} {
    file delete $name
}

# makeDirectory --
#
# Create a new dir with the name <name>.
#
# If this dir hasn't been created via makeDirectory since the last time
# cleanupTests was called, add it to the $directoriesMade list, so it will
# be removed by the next call to cleanupTests.
#
proc ::test::makeDirectory {name} {
    file mkdir $name

    set fullName [file join [pwd] $name]
    if {[lsearch $::test::filesMade $fullName] == -1} {
	lappend ::test::filesMade $fullName
    }
}

proc ::test::removeDirectory {name} {
    file delete -force $name
}

proc ::test::viewFile {name} {
    global tcl_platform
    if {($tcl_platform(platform) == "macintosh") || \
		($::test::testConfig(unixExecs) == 0)} {
	set f [open $name]
	set data [read -nonewline $f]
	close $f
	return $data
    } else {
	exec cat $name
    }
................................................................................
#    to confirm that "\xe0\0" in a Tcl script is stored internally in 
#    UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
#
# Generally, it's a bad idea to examine the bytes in a Tcl string or to
# construct improperly formed strings in this manner, because it involves
# exposing that Tcl uses UTF-8 internally.

proc ::test::bytestring {string} {
    encoding convertfrom identity $string
}

# Locate tcltest executable

set tcltest [info nameofexecutable]

if {$tcltest == "{}"} {
    set tcltest {}
    puts stdout "Unable to find tcltest executable, multiple process tests will fail."
}

set ::test::testConfig(stdio) 0
if {$tcl_platform(os) != "Win32s"} {
    # Don't even try running another copy of tcltest under win32s, or you 
    # get an error dialog about multiple instances.

    catch {
	file delete -force tmp
	set f [open tmp w]
	puts $f {
	    exit
	}
	close $f




	set f [open "|[list $tcltest tmp]" r]
	close $f

	set ::test::testConfig(stdio) 1
    }
    catch {file delete -force tmp}
}

if {($tcl_platform(platform) == "windows") && ($::test::testConfig(stdio) == 0)} {
    puts stdout "(will skip tests that redirect stdio of exec'd 32-bit applications)"
}

catch {socket} msg
set ::test::testConfig(socket) [expr {$msg != "sockets are not available on this system"}]

if {$::test::testConfig(socket) == 0} {
    puts stdout "(will skip tests that use sockets)"
}

#
# Internationalization / ISO support procs     -- dl
#
if {[info commands testlocale]==""} {
    # No testlocale command, no tests...
    # (it could be that we are a sub interp and we could just load
    # the Tcltest package but that would interfere with tests
    # that tests packages/loading in slaves...)
    set ::test::testConfig(hasIsoLocale) 0
} else {
    proc ::test::set_iso8859_1_locale {} {
	set ::test::previousLocale [testlocale ctype]
	testlocale ctype $::test::isoLocale
    }

    proc ::test::restore_locale {} {
	testlocale ctype $::test::previousLocale
    }

    if {![info exists ::test::isoLocale]} {
	set ::test::isoLocale fr
        switch $tcl_platform(platform) {
	    "unix" {
		# Try some 'known' values for some platforms:
		switch -exact -- $tcl_platform(os) {
		    "FreeBSD" {
			set ::test::isoLocale fr_FR.ISO_8859-1
		    }
		    HP-UX {
			set ::test::isoLocale fr_FR.iso88591
		    }
		    Linux -
		    IRIX {
			set ::test::isoLocale fr
		    }
		    default {
			# Works on SunOS 4 and Solaris, and maybe others...
			# define it to something else on your system
			#if you want to test those.
			set ::test::isoLocale iso_8859_1
		    }
		}
	    }
	    "windows" {
		set ::test::isoLocale French
	    }
	}
    }

    set ::test::testConfig(hasIsoLocale) \
	    [string length [::test::set_iso8859_1_locale]]
    ::test::restore_locale

    if {$::test::testConfig(hasIsoLocale) == 0} {
	puts "(will skip tests that need to set an iso8859-1 locale)"
    }







} 

























































































# Need to catch the import because it fails if defs.tcl is sourced
# more than once.
catch {namespace import ::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
..
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
...
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
...
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
...
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
...
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
# defs.tcl --
#
#	This file contains support code for the Tcl/Tk test suite.It is
#	It is normally sourced by the individual files in the test suite
#	before they run their tests.  This improved approach to testing
#	was designed and initially implemented by Mary Ann May-Pumphrey
#	of Sun Microsystems.
#
# Copyright (c) 1990-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: defs.tcl,v 1.1.2.3 1999/03/23 20:06:16 hershey Exp $

# Initialize wish shell
if {[info exists tk_version]} {
    tk appname tktest
    wm title . tktest
} else {
    # Ensure that we have a minimal auto_path so we don't pick up extra junk.
    set auto_path [list [info library]]
}

# create the "test" namespace for all testing variables and procedures
namespace eval tcltest {
    set procList [list test cleanupTests dotests saveState restoreState \
	    normalizeMsg makeFile removeFile makeDirectory removeDirectory \
	    viewFile safeFetch bytestring set_iso8859_1_locale restore_locale \
	    setTmpDir]
    if {[info exists tk_version]} {
	lappend procList setupbg dobg bgReady cleanupbg fixfocus
    }
    foreach proc $procList {
	namespace export $proc
    }

    # ::tcltest::verbose defaults to "b"
    variable verbose "b"

    # matchingTests defaults to the empty list
    variable matchingTests {}

    # skippingTests defaults to the empty list
    variable skippingTests {}

    # Tests should not rely on the current working directory.
    # Files that are part of the test suite should be accessed relative to
    # ::tcltest::testsDir.

    set originalDir [pwd]
    set tDir [file join $originalDir [file dirname [info script]]]
    cd $tDir
    variable testsDir [pwd]
    cd $originalDir

................................................................................

    variable numTestFiles 0
    variable testSingleFile true
    variable currentFailure false
    variable failFiles {}

    # Tests should remove all files they create.  The test suite will
    # check tmpDir for files created by the tests.  ::tcltest::filesMade
    # keeps track of such files created using the ::tcltest::makeFile and
    # ::tcltest::makeDirectory procedures.  ::tcltest::filesExisted stores
    # the names of pre-existing files.

    variable filesMade {}
    variable filesExisted {}

    # initialize ::tcltest::numTests array to keep track fo the number of
    # tests that pass, fial, and are skipped.
    array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0]

    # initialize ::tcltest::skippedBecause array to keep track of
    # constraints that kept tests from running
    array set ::tcltest::skippedBecause {}
}

# If there is no "memory" command (because memory debugging isn't
# enabled), generate a dummy command that does nothing.

if {[info commands memory] == ""} {
    proc memory args {}
}

# ::tcltest::initConfig --
#
# Check configuration information that will determine which tests
# to run.  To do this, create an array ::tcltest::testConfig.  Each
# element has a 0 or 1 value.  If the element is "true" then tests
# with that constraint will be run, otherwise tests with that constraint
# will be skipped.  See the README file for the list of built-in
# constraints defined in this procedure.
#
# Arguments:
#	none
#
# Results:
#	The ::tcltest::testConfig array is reset to have an index for
#	each built-in test constraint.

proc ::tcltest::initConfig {} {

    global tcl_platform tcl_interactive tk_version

    catch {unset ::tcltest::testConfig}

    # The following trace procedure makes it so that we can safely refer to
    # non-existent members of the ::tcltest::testConfig array without causing an
    # error.  Instead, reading a non-existent member will return 0.  This is
    # necessary because tests are allowed to use constraint "X" without ensuring
    # that ::tcltest::testConfig("X") is defined.

    trace variable ::tcltest::testConfig r ::tcltest::safeFetch

    proc ::tcltest::safeFetch {n1 n2 op} {
	if {($n2 != {}) && ([info exists ::tcltest::testConfig($n2)] == 0)} {
	    set ::tcltest::testConfig($n2) 0
	}
    }

    set ::tcltest::testConfig(unixOnly) [expr {$tcl_platform(platform) == "unix"}]
    set ::tcltest::testConfig(macOnly) [expr {$tcl_platform(platform) == "macintosh"}]
    set ::tcltest::testConfig(pcOnly) [expr {$tcl_platform(platform) == "windows"}]

    set ::tcltest::testConfig(unix) $::tcltest::testConfig(unixOnly)
    set ::tcltest::testConfig(mac) $::tcltest::testConfig(macOnly)
    set ::tcltest::testConfig(pc) $::tcltest::testConfig(pcOnly)

    set ::tcltest::testConfig(unixOrPc) \
	    [expr {$::tcltest::testConfig(unix) || $::tcltest::testConfig(pc)}]
    set ::tcltest::testConfig(macOrPc) \
	    [expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(pc)}]
    set ::tcltest::testConfig(macOrUnix) \
	    [expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(unix)}]

    set ::tcltest::testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}]
    set ::tcltest::testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}]

    # The following config switches are used to mark tests that should work,
    # but have been temporarily disabled on certain platforms because they don't
    # and we haven't gotten around to fixing the underlying problem.

    set ::tcltest::testConfig(tempNotPc) [expr {!$::tcltest::testConfig(pc)}]
    set ::tcltest::testConfig(tempNotMac) [expr {!$::tcltest::testConfig(mac)}]
    set ::tcltest::testConfig(tempNotUnix) [expr {!$::tcltest::testConfig(unix)}]

    # The following config switches are used to mark tests that crash on
    # certain platforms, so that they can be reactivated again when the
    # underlying problem is fixed.

    set ::tcltest::testConfig(pcCrash) [expr {!$::tcltest::testConfig(pc)}]
    set ::tcltest::testConfig(macCrash) [expr {!$::tcltest::testConfig(mac)}]
    set ::tcltest::testConfig(unixCrash) [expr {!$::tcltest::testConfig(unix)}]

    # Set the "fonts" constraint for wish apps
    if {[info exists tk_version]} {
	set ::tcltest::testConfig(fonts) 1
	catch {destroy .e}
	entry .e -width 0 -font {Helvetica -12} -bd 1
	.e insert end "a.bcd"
	if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
	    set ::tcltest::testConfig(fonts) 0
	}
	destroy .e
	catch {destroy .t}
	text .t -width 80 -height 20 -font {Times -14} -bd 1
	pack .t
	.t insert end "This is\na dot."
	update
	set x [list [.t bbox 1.3] [.t bbox 2.5]]
	destroy .t
	if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} {
	    set ::tcltest::testConfig(fonts) 0
	}
    }

    # By default, non-portable tests are skipped.
    set ::tcltest::testConfig(nonPortable) 0

    # By default, tests that expost known bugs are skipped.
    set ::tcltest::testConfig(knownBug) 0

    # Some tests must be skipped if the interpreter is not in interactive mode
    set ::tcltest::testConfig(interactive) $tcl_interactive

    # Some tests must be skipped if you are running as root on Unix.
    # Other tests can only be run if you are running as root on Unix.
    set ::tcltest::testConfig(root) 0
    set ::tcltest::testConfig(notRoot) 1
    set user {}
    if {$tcl_platform(platform) == "unix"} {
	catch {set user [exec whoami]}
	if {$user == ""} {
	    catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
	}
	if {($user == "root") || ($user == "")} {
	    set ::tcltest::testConfig(root) 1
	    set ::tcltest::testConfig(notRoot) 0
	}
    }

    # Set nonBlockFiles constraint: 1 means this platform supports
    # setting files into nonblocking mode.
    if {[catch {set f [open defs r]}]} {
	set ::tcltest::testConfig(nonBlockFiles) 1
    } else {
	if {[catch {fconfigure $f -blocking off}] == 0} {
	    set ::tcltest::testConfig(nonBlockFiles) 1
	} else {
	    set ::tcltest::testConfig(nonBlockFiles) 0
	}
	close $f
    }

    # Set asyncPipeClose constraint: 1 means this platform supports
    # async flush and async close on a pipe.
    #
    # Test for SCO Unix - cannot run async flushing tests because a
    # potential problem with select is apparently interfering.
    # (Mark Diekhans).
    if {$tcl_platform(platform) == "unix"} {
	if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
	    set ::tcltest::testConfig(asyncPipeClose) 0
	} else {
	    set ::tcltest::testConfig(asyncPipeClose) 1
	}
    } else {
	set ::tcltest::testConfig(asyncPipeClose) 1
    }

    # Test to see if we have a broken version of sprintf with respect
    # to the "e" format of floating-point numbers.
    set ::tcltest::testConfig(eformat) 1
    if {[string compare "[format %g 5e-5]" "5e-05"] != 0} {
	set ::tcltest::testConfig(eformat) 0
    }

    # Test to see if execed commands such as cat, echo, rm and so forth are
    # present on this machine.
    set ::tcltest::testConfig(unixExecs) 1
    if {$tcl_platform(platform) == "macintosh"} {
	set ::tcltest::testConfig(unixExecs) 0
    }
    if {($::tcltest::testConfig(unixExecs) == 1) && \
	    ($tcl_platform(platform) == "windows")} {
	if {[catch {exec cat defs}] == 1} {
	    set ::tcltest::testConfig(unixExecs) 0
	}
	if {($::tcltest::testConfig(unixExecs) == 1) && \
		([catch {exec echo hello}] == 1)} {
	    set ::tcltest::testConfig(unixExecs) 0
	}
	if {($::tcltest::testConfig(unixExecs) == 1) && \
		([catch {exec sh -c echo hello}] == 1)} {
	    set ::tcltest::testConfig(unixExecs) 0
	}
	if {($::tcltest::testConfig(unixExecs) == 1) && \
		([catch {exec wc defs}] == 1)} {
	    set ::tcltest::testConfig(unixExecs) 0
	}
	if {$::tcltest::testConfig(unixExecs) == 1} {
	    exec echo hello > removeMe
	    if {[catch {exec rm removeMe}] == 1} {
		set ::tcltest::testConfig(unixExecs) 0
	    }
	}
	if {($::tcltest::testConfig(unixExecs) == 1) && \
		([catch {exec sleep 1}] == 1)} {
	    set ::tcltest::testConfig(unixExecs) 0
	}
	if {($::tcltest::testConfig(unixExecs) == 1) && \
		([catch {exec fgrep unixExecs defs}] == 1)} {
	    set ::tcltest::testConfig(unixExecs) 0
	}
	if {($::tcltest::testConfig(unixExecs) == 1) && \
		([catch {exec ps}] == 1)} {
	    set ::tcltest::testConfig(unixExecs) 0
	}
	if {($::tcltest::testConfig(unixExecs) == 1) && \
		([catch {exec echo abc > removeMe}] == 0) && \
		([catch {exec chmod 644 removeMe}] == 1) && \
		([catch {exec rm removeMe}] == 0)} {
	    set ::tcltest::testConfig(unixExecs) 0
	} else {
	    catch {exec rm -f removeMe}
	}
	if {($::tcltest::testConfig(unixExecs) == 1) && \
		([catch {exec mkdir removeMe}] == 1)} {
	    set ::tcltest::testConfig(unixExecs) 0
	} else {
	    catch {exec rm -r removeMe}
	}
    }
}

::tcltest::initConfig


# ::tcltest::setTmpDir --
#
#	Set the ::tcltest::tmpDir to the specified value.  If the path
#	is relative, make it absolute.  If the file exists but is not
#	a dir, then return an error.  If the dir does not already
#	exist, create it.  If you cannot create it, then return an error.
#
# Arguments:
#	value	the new value of ::tcltest::tmpDir
#
# Results:
#	::tcltest::tmpDir is set to <value> and created if it didn't already
#	exist.  The working dir is changed to ::tcltest::tmpDir.

proc ::tcltest::setTmpDir {value} {

    set ::tcltest::tmpDir $value

    if {[string compare [file pathtype $::tcltest::tmpDir] absolute] != 0} {
	set ::tcltest::tmpDir [file join [pwd] $::tcltest::tmpDir]
    }
    if {[file exists $::tcltest::tmpDir]} {
	if {![file isdir $::tcltest::tmpDir]} {
	    puts stderr "Error:  bad argument \"$value\" to -tmpdir:"
	    puts stderr "            \"$::tcltest::tmpDir\""
	    puts stderr "        is not a directory"
	    exit
	}
    } else {
	file mkdir $::tcltest::tmpDir
    }

    # change the working dir to tmpDir and add the existing files in
    # tmpDir to the filesExisted list.
    cd $::tcltest::tmpDir
    foreach file [glob -nocomplain [file join [pwd] *]] {
	lappend ::tcltest::filesExisted $file
    }
}

# ::tcltest::processCmdLineArgs --
#
#	Use command line args to set the tmpDir, verbose, skippingTests, and
#	matchingTests variables.
#
# Arguments:
#	none
#
# Results:
#	::tcltest::verbose is set to <value>

proc ::tcltest::processCmdLineArgs {} {
    global argv

    # The "argv" var doesn't exist in some cases, so use {}
    # The "argv" var doesn't exist in some cases.
    if {(![info exists argv]) || ([llength $argv] < 2)} {
	set flagArray {}
    } else {
................................................................................
    if {[catch {array set flag $flagArray}]} {
	puts stderr "Error:  odd number of command line args specified:"
	puts stderr "        $argv"
	exit
    }
    
    # Allow for 1-char abbreviations, where applicable (e.g., -tmpdir == -t).
    # Note that -verbose cannot be abbreviated to -v in wish because it conflicts
    # with the wish option -visual.
    foreach arg {-verbose -match -skip -constraints -tmpdir} {
	set abbrev [string range $arg 0 1]
	if {([info exists flag($abbrev)]) && \
		([lsearch -exact $flagArray $arg] < [lsearch -exact $flagArray $abbrev])} {
	    set flag($arg) $flag($abbrev)
	}
    }

    # Set ::tcltest::tmpDir to the arg of the -tmpdir flag, if given.
    # ::tcltest::tmpDir defaults to [pwd].
    # Save the names of files that already exist in ::tcltest::tmpDir.
    if {[info exists flag(-tmpdir)]} {
	::tcltest::setTmpDir $flag(-tmpdir)
    } else {
	set ::tcltest::tmpDir [pwd]
    }
    foreach file [glob -nocomplain [file join $::tcltest::tmpDir *]] {
	lappend ::tcltest::filesExisted [file tail $file]
    }

    # Set ::tcltest::verbose to the arg of the -verbose flag, if given
    if {[info exists flag(-verbose)]} {
	set ::tcltest::verbose $flag(-verbose)
    }

    # Set ::tcltest::matchingTests to the arg of the -match flag, if given
    if {[info exists flag(-match)]} {
	set ::tcltest::matchingTests $flag(-match)
    }

    # Set ::tcltest::skippingTests to the arg of the -skip flag, if given
    if {[info exists flag(-skip)]} {
	set ::tcltest::skippingTests $flag(-skip)
    }

    # Use the -constraints flag, if given, to turn on the following
    # constraints:  knownBug and nonPortable
    if {[info exists flag(-constraints)]} {
	set constrList $flag(-constraints)
    } else {
	set constrList {}
    }
    foreach elt [list knownBug nonPortable] {
	set ::tcltest::testConfig($elt) \
		[expr {[lsearch -exact $constrList $elt] != -1}]
    }


}

::tcltest::processCmdLineArgs















































































































































































































# ::tcltest::cleanupTests --
#
# Remove files and dirs created using the makeFile and makeDirectory
# commands since the last time this proc was invoked.
#
# Print the names of the files created without the makeFile command
# since the tests were invoked.
#
# Print the number tests (total, passed, failed, and skipped) since the
# tests were invoked.
#

proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
    # remove files and directories created by the tests
    foreach file $::tcltest::filesMade {
	if {[file exists $file]} {
	    catch {file delete -force $file}
	}
    }

    set tail [file tail [info script]]
    if {$calledFromAllFile || $::tcltest::testSingleFile} {
	# print stats
	puts -nonewline stdout "$tail:"
	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
	    puts -nonewline stdout "\t$index\t$::tcltest::numTests($index)"
	}
	puts stdout ""

	# print number test files sourced
	# print names of files that ran tests which failed
	if {$calledFromAllFile} {
	    puts stdout "Sourced $::tcltest::numTestFiles Test Files."
	    set ::tcltest::numTestFiles 0
	    if {[llength $::tcltest::failFiles] > 0} {
		puts stdout "Files with failing tests: $::tcltest::failFiles"
		set ::tcltest::failFiles {}
	    }
	}

	# if any tests were skipped, print the constraints that kept them
	# from running.
	if {$::tcltest::numTests(Skipped) > 0} {
	    puts stdout "Number of tests skipped for each constraint:"
	    foreach constraint [lsort [array names ::tcltest::skippedBecause]] {
		puts stdout \
			"\t$::tcltest::skippedBecause($constraint)\t$constraint"
		unset ::tcltest::skippedBecause($constraint)
	    }
	}

	# report the names of files in ::tcltest::tmpDir that were not pre-existing.
	set currentFiles {}
	foreach file [glob -nocomplain [file join $::tcltest::tmpDir *]] {
	    lappend currentFiles [file tail $file]
	}
	set filesNew {}
	foreach file $currentFiles {
	    if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
		lappend filesNew $file
	    }
	}
	if {[llength $filesNew] > 0} {
	    puts stdout "Warning: created files:\t$filesNew"
	}

	# reset filesMade, filesExisted, and numTests
	set ::tcltest::filesMade {}
	set ::tcltest::filesExisted $currentFiles
	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
	    set ::tcltest::numTests($index) 0
	}

	# exit only if running Tk in non-interactive mode
	global tk_version tcl_interactive
	if {[info exists tk_version] && !$tcl_interactive} {
	    exit
	}
    } else {
	# if we're deferring stat-reporting until all files are sourced,
	# then add current file to failFile list if any tests in this file
	# failed
	incr ::tcltest::numTestFiles
	if {($::tcltest::currentFailure) && \
		([lsearch -exact $::tcltest::failFiles $tail] == -1)} {
	    lappend ::tcltest::failFiles $tail
	}
	set ::tcltest::currentFailure false
    }
}


# test --
#
# This procedure runs a test and prints an error message if the test fails.
# If ::tcltest::verbose has been set, it also prints a message even if the
# test succeeds.  The test will be skipped if it doesn't match the
# ::tcltest::matchingTests variable, if it matches an element in
# ::tcltest::skippingTests, or if one of the elements of "constraints" turns
# out not to be true.
#
# Arguments:
# name -		Name of test, in the form foo-1.2.
# description -		Short textual description of the test, to
#			help humans understand what it does.
# constraints -		A list of one or more keywords, each of
#			which must be the name of an element in
#			the array "::tcltest::testConfig".  If any of these
#			elements is zero, the test is skipped.
#			This argument may be omitted.
# script -		Script to run to carry out the test.  It must
#			return a result that can be checked for
#			correctness.
# expectedAnswer -	Expected result from script.

proc ::tcltest::test {name description script expectedAnswer args} {
    incr ::tcltest::numTests(Total)

    # skip the test if it's name matches an element of skippingTests
    foreach pattern $::tcltest::skippingTests {
	if {[string match $pattern $name]} {
	    incr ::tcltest::numTests(Skipped)
	    return
	}
    }
    # skip the test if it's name doesn't match any element of matchingTests
    if {[llength $::tcltest::matchingTests] > 0} {
	set ok 0
	foreach pattern $::tcltest::matchingTests {
	    if {[string match $pattern $name]} {
		set ok 1
		break
	    }
        }
	if {!$ok} {
	    incr ::tcltest::numTests(Skipped)
	    return
	}
    }
    set i [llength $args]
    if {$i == 0} {
	set constraints {}
    } elseif {$i == 1} {
................................................................................
	set doTest 0
	if {[string match {*[$\[]*} $constraints] != 0} {
	    # full expression, e.g. {$foo > [info tclversion]}

	    catch {set doTest [uplevel #0 expr $constraints]}
	} elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
	    # something like {a || b} should be turned into 
	    # $::tcltest::testConfig(a) || $::tcltest::testConfig(b).

 	    regsub -all {[.a-zA-Z0-9]+} $constraints {$::tcltest::testConfig(&)} c
	    catch {set doTest [eval expr $c]}
	} else {
	    # just simple constraints such as {unixOnly fonts}.

	    set doTest 1
	    foreach constraint $constraints {
		if {![info exists ::tcltest::testConfig($constraint)]
			|| !$::tcltest::testConfig($constraint)} {
		    set doTest 0
		    # store the constraint that kept the test from running
		    set constraints $constraint
		    break
		}
	    }
	}
	if {$doTest == 0} {
	    incr ::tcltest::numTests(Skipped)
	    if {[string first s $::tcltest::verbose] != -1} {
		puts stdout "++++ $name SKIPPED: $constraints"
	    }
	    # add the constraint to the list of constraints the kept tests
	    # from running
	    if {[info exists ::tcltest::skippedBecause($constraints)]} {
		incr ::tcltest::skippedBecause($constraints)
	    } else {
		set ::tcltest::skippedBecause($constraints) 1
	    }
	    return	
	}
    } else {
	error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
    }
    memory tag $name
    set code [catch {uplevel $script} actualAnswer]
    if {$code != 0 || [string compare $actualAnswer $expectedAnswer] != 0} {
	incr ::tcltest::numTests(Failed)
	set ::tcltest::currentFailure true
	if {[string first b $::tcltest::verbose] == -1} {
	    set script ""
	}
	puts stdout "\n==== $name $description FAILED"
	if {$script != ""} {
	    puts stdout "==== Contents of test case:"
	    puts stdout $script
	}
................................................................................
	    }
	} else {
	    puts stdout "---- Result was:\n$actualAnswer"
	}
	puts stdout "---- Result should have been:\n$expectedAnswer"
	puts stdout "==== $name FAILED\n" 
    } else { 
	incr ::tcltest::numTests(Passed)
	if {[string first p $::tcltest::verbose] != -1} {
	    puts stdout "++++ $name PASSED"
	}
    }
}

proc ::tcltest::dotests {file args} {
    set savedTests $::tcltest::matchingTests
    set ::tcltest::matchingTests $args
    source $file
    set ::tcltest::matchingTests $savedTests
}

proc ::tcltest::openfiles {} {
    if {[catch {testchannel open} result]} {
	return {}
    }
    return $result
}

proc ::tcltest::leakfiles {old} {
    if {[catch {testchannel open} new]} {
        return {}
    }
    set leak {}
    foreach p $new {
    	if {[lsearch $old $p] < 0} {
	    lappend leak $p
	}
    }
    return $leak
}

set ::tcltest::saveState {}

proc ::tcltest::saveState {} {
    uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
}

proc ::tcltest::restoreState {} {
    foreach p [info procs] {
	if {[lsearch [lindex $::tcltest::saveState 0] $p] < 0} {
	    rename $p {}
	}
    }
    foreach p [uplevel #0 {info vars}] {
	if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
	    uplevel #0 "unset $p"
	}
    }
}

proc ::tcltest::normalizeMsg {msg} {
    regsub "\n$" [string tolower $msg] "" msg
    regsub -all "\n\n" $msg "\n" msg
    regsub -all "\n\}" $msg "\}" msg
    return $msg
}

# makeFile --
................................................................................
#
# Create a new file with the name <name>, and write <contents> to it.
#
# If this file hasn't been created via makeFile since the last time
# cleanupTests was called, add it to the $filesMade list, so it will
# be removed by the next call to cleanupTests.
#
proc ::tcltest::makeFile {contents name} {
    set fd [open $name w]
    fconfigure $fd -translation lf
    if {[string index $contents [expr {[string length $contents] - 1}]] == "\n"} {
	puts -nonewline $fd $contents
    } else {
	puts $fd $contents
    }
    close $fd

    set fullName [file join [pwd] $name]
    if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
	lappend ::tcltest::filesMade $fullName
    }
}

proc ::tcltest::removeFile {name} {
    file delete $name
}

# makeDirectory --
#
# Create a new dir with the name <name>.
#
# If this dir hasn't been created via makeDirectory since the last time
# cleanupTests was called, add it to the $directoriesMade list, so it will
# be removed by the next call to cleanupTests.
#
proc ::tcltest::makeDirectory {name} {
    file mkdir $name

    set fullName [file join [pwd] $name]
    if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
	lappend ::tcltest::filesMade $fullName
    }
}

proc ::tcltest::removeDirectory {name} {
    file delete -force $name
}

proc ::tcltest::viewFile {name} {
    global tcl_platform
    if {($tcl_platform(platform) == "macintosh") || \
		($::tcltest::testConfig(unixExecs) == 0)} {
	set f [open $name]
	set data [read -nonewline $f]
	close $f
	return $data
    } else {
	exec cat $name
    }
................................................................................
#    to confirm that "\xe0\0" in a Tcl script is stored internally in 
#    UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
#
# Generally, it's a bad idea to examine the bytes in a Tcl string or to
# construct improperly formed strings in this manner, because it involves
# exposing that Tcl uses UTF-8 internally.

proc ::tcltest::bytestring {string} {
    encoding convertfrom identity $string
}

# Locate tcltest executable

set tcltest [info nameofexecutable]

if {$tcltest == "{}"} {
    set tcltest {}
    puts stdout "Unable to find tcltest executable, multiple process tests will fail."
}

set ::tcltest::testConfig(stdio) 0




catch {
    catch {file delete -force tmp}
    set f [open tmp w]
    puts $f {
	exit
    }
    close $f
    # The following 2 lines cannot be run on Windows in Tk8.1b2
    # This bug is logged as a pipe bug (bugID 1495).

    if {($tcl_platform(os) != "windows") || (![info exists tk_version])} {
	set f [open "|[list $tcltest tmp]" r]
	close $f
    }
    set ::tcltest::testConfig(stdio) 1
}
catch {file delete -force tmp}






catch {socket} msg
set ::tcltest::testConfig(socket) [expr {$msg != "sockets are not available on this system"}]





#
# Internationalization / ISO support procs     -- dl
#
if {[info commands testlocale]==""} {
    # No testlocale command, no tests...
    # (it could be that we are a sub interp and we could just load
    # the Tcltest package but that would interfere with tests
    # that tests packages/loading in slaves...)
    set ::tcltest::testConfig(hasIsoLocale) 0
} else {
    proc ::tcltest::set_iso8859_1_locale {} {
	set ::tcltest::previousLocale [testlocale ctype]
	testlocale ctype $::tcltest::isoLocale
    }

    proc ::tcltest::restore_locale {} {
	testlocale ctype $::tcltest::previousLocale
    }

    if {![info exists ::tcltest::isoLocale]} {
	set ::tcltest::isoLocale fr
        switch $tcl_platform(platform) {
	    "unix" {
		# Try some 'known' values for some platforms:
		switch -exact -- $tcl_platform(os) {
		    "FreeBSD" {
			set ::tcltest::isoLocale fr_FR.ISO_8859-1
		    }
		    HP-UX {
			set ::tcltest::isoLocale fr_FR.iso88591
		    }
		    Linux -
		    IRIX {
			set ::tcltest::isoLocale fr
		    }
		    default {
			# Works on SunOS 4 and Solaris, and maybe others...
			# define it to something else on your system
			#if you want to test those.
			set ::tcltest::isoLocale iso_8859_1
		    }
		}
	    }
	    "windows" {
		set ::tcltest::isoLocale French
	    }
	}
    }

    set ::tcltest::testConfig(hasIsoLocale) \
	    [string length [::tcltest::set_iso8859_1_locale]]
    ::tcltest::restore_locale
} 



#
# procedures that are Tk specific
#
if {[info exists tk_version]} {
    # If the main window isn't already mapped (e.g. because the tests are
    # being run automatically) , specify a precise size for it so that the
    # user won't have to position it manually.

    if {![winfo ismapped .]} {
	wm geometry . +0+0
	update
    }

    # The following code can be used to perform tests involving a second
    # process running in the background.
    
    # Locate tktest executable

    set ::tcltest::tktest [info nameofexecutable]
    if {$::tcltest::tktest == "{}"} {
	set ::tcltest::tktest {}
	puts stdout "Unable to find tktest executable, skipping multiple process tests."
    }

    # Create background process
    
    proc ::tcltest::setupbg args {
	if {$::tcltest::tktest == ""} {
	    error "you're not running tktest so setupbg should not have been called"
	}
	if {[info exists ::tcltest::fd] && ($::tcltest::fd != "")} {
	    cleanupbg
	}
	set ::tcltest::fd [open "|[list $::tcltest::tktest -geometry +0+0 -name tktest] $args" r+]
	puts $::tcltest::fd "puts foo; flush stdout"
	flush $::tcltest::fd
	if {[gets $::tcltest::fd data] < 0} {
	    error "unexpected EOF from \"$::tcltest::tktest\""
	}
	if {[string compare $data foo]} {
	    error "unexpected output from background process \"$data\""
	}
	fileevent $::tcltest::fd readable bgReady
    }
    
    # Send a command to the background process, catching errors and
    # flushing I/O channels
    proc ::tcltest::dobg {command} {
	puts $::tcltest::fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout"
	flush $::tcltest::fd
	set ::tcltest::bgDone 0
	set ::tcltest::bgData {}
	tkwait variable ::tcltest::bgDone
	set ::tcltest::bgData
    }

    # Data arrived from background process.  Check for special marker
    # indicating end of data for this command, and make data available
    # to dobg procedure.
    proc ::tcltest::bgReady {} {
	set x [gets $::tcltest::fd]
	if {[eof $::tcltest::fd]} {
	    fileevent $::tcltest::fd readable {}
	    set ::tcltest::bgDone 1
	} elseif {$x == "**DONE**"} {
	    set ::tcltest::bgDone 1
	} else {
	    append ::tcltest::bgData $x
	}
    }

    # Exit the background process, and close the pipes
    proc ::tcltest::cleanupbg {} {
	catch {
	    puts $::tcltest::fd "exit"
	    close $::tcltest::fd
	}
	set ::tcltest::fd ""
    }

    # Clean up focus after using generate event, which
    # can leave the window manager with the wrong impression
    # about who thinks they have the focus. (BW)
    
    proc ::tcltest::fixfocus {} {
	catch {destroy .focus}
	toplevel .focus
	wm geometry .focus +0+0
	entry .focus.e
	.focus.e insert 0 "fixfocus"
	pack .focus.e
	update
	focus -force .focus.e
	destroy .focus
    }
}

# Need to catch the import because it fails if defs.tcl is sourced
# more than once.
catch {namespace import ::tcltest::*}










Changes to tests/dstring.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
246
247
248
249
250
251
252
253
254
255










# 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.
#
# RCS: @(#) $Id: dstring.test,v 1.1.2.3 1999/03/11 18:49:31 hershey Exp $

if {[info commands testdstring] == {}} {
    puts "This application hasn't been compiled with the \"testdstring\""
    puts "command, so I can't test Tcl_DStringAppend et al."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test dstring-1.1 {appending and retrieving} {
    testdstring free
    testdstring append "abc" -1
    list [testdstring get] [testdstring length]
................................................................................
    lappend result [testdstring gresult special]
    testdstring append z 1
    lappend result [testdstring get]
} {{} {This is a specially-allocated stringz}}

# cleanup
testdstring free
::test::cleanupTests
return

















|







|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
# 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.
#
# RCS: @(#) $Id: dstring.test,v 1.1.2.4 1999/03/23 20:06:17 hershey Exp $

if {[info commands testdstring] == {}} {
    puts "This application hasn't been compiled with the \"testdstring\""
    puts "command, so I can't test Tcl_DStringAppend et al."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test dstring-1.1 {appending and retrieving} {
    testdstring free
    testdstring append "abc" -1
    list [testdstring get] [testdstring length]
................................................................................
    lappend result [testdstring gresult special]
    testdstring append z 1
    lappend result [testdstring get]
} {{} {This is a specially-allocated stringz}}

# cleanup
testdstring free
::tcltest::cleanupTests
return











Changes to tests/encoding.test.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
292
293
294
295
296
297
298
299
300










301
302
303
#
# 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.
#
# RCS: @(#) $Id: encoding.test,v 1.1.2.4 1999/03/11 18:49:32 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc toutf {args} {
    global x
    lappend x "toutf $args"
}
................................................................................
test encoding-22.1 {EscapeFromUtfProc} {
} {}

# EscapeFreeProc, GetTableEncoding, unilen
# are fully tested by the rest of this file

# cleanup
::test::cleanupTests
return



















|

|







 







|

>
>
>
>
>
>
>
>
>
>



4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
#
# 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.
#
# RCS: @(#) $Id: encoding.test,v 1.1.2.5 1999/03/23 20:06:17 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc toutf {args} {
    global x
    lappend x "toutf $args"
}
................................................................................
test encoding-22.1 {EscapeFromUtfProc} {
} {}

# EscapeFreeProc, GetTableEncoding, unilen
# are fully tested by the rest of this file

# cleanup
::tcltest::cleanupTests
return













Changes to tests/env.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
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
...
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










# 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.
#
# RCS: @(#) $Id: env.test,v 1.1.2.4 1999/03/11 18:49:32 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

#
# These tests will run on any platform (and indeed crashed
# on the Mac).  So put them before you test for the existance
# of exec.
................................................................................
    child eval {set env(test) garbage}
    set names [array names env]
    interp delete child
    set ix [lsearch $names test]
    catch {unset env(test)}
    expr {$ix >= 0}
} {1}
#



if {[info commands exec] == ""} {
    puts "exec not implemented for this machine"
    return
}

if {$tcl_platform(os) == "Win32s"} {
    puts "Cannot run multiple copies of tcl at the same time under Win32s"
    return
}
   
set f [open printenv w]
puts $f {
    proc lrem {listname name} {
	upvar $listname list
	set i [lsearch $list $name]
	if {$i >= 0} {
	    set list [lreplace $list $i $i]
................................................................................
# ('saved' env vars)
foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH DISPLAY SHLIB_PATH} {
  if {[info exists env2($name)]} {
     set env($name) $env2($name);
  }
}

test env-2.1 {adding environment variables} {
    getenv
} {}

set env(NAME1) "test string"
test env-2.2 {adding environment variables} {
    getenv
} {NAME1=test string}

set env(NAME2) "more"
test env-2.3 {adding environment variables} {
    getenv
} {NAME1=test string
NAME2=more}

set env(XYZZY) "garbage"
test env-2.4 {adding environment variables} {
    getenv
} {NAME1=test string
NAME2=more
XYZZY=garbage}

set env(NAME2) "new value"
test env-3.1 {changing environment variables} {
    getenv


} {NAME1=test string
NAME2=new value
XYZZY=garbage}

unset env(NAME2)
test env-4.1 {unsetting environment variables} {
    getenv


} {NAME1=test string
XYZZY=garbage}
unset env(NAME1)

test env-4.2 {unsetting environment variables} {
    getenv
} {XYZZY=garbage}
unset env(XYZZY)



test env-4.3 {setting international environment variables} {
    set env(\ua7) \ub6
    getenv
} "\ua7=\ub6"
test env-4.4 {changing international environment variables} {
    set env(\ua7) \ua7
    getenv
} "\ua7=\ua7"
test env-4.5 {unsetting international environment variables} {
    set env(\ub6) \ua7
    unset env(\ua7)
    getenv
} "\ub6=\ua7"
unset env(\ub6)



# Restore the environment variables at the end of the test.

foreach name [array names env] {
    unset env($name)
}
foreach name [array names env2] {
    set env($name) $env2($name)
}

# cleanup
file delete printenv
::test::cleanupTests
return

















|

|







 







|

>
>
|
<
<
|
<
<
<
<
<
<







 







|




|




|





|






|
|
>
>




<
|
|
>
>


<
>
|
|
<
|
>
>

|



|



|


|
<
|
>
>












|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
49
50
51
52
53
54
55
56
57
58
59
60


61






62
63
64
65
66
67
68
...
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
# 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.
#
# RCS: @(#) $Id: env.test,v 1.1.2.5 1999/03/23 20:06:18 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

#
# These tests will run on any platform (and indeed crashed
# on the Mac).  So put them before you test for the existance
# of exec.
................................................................................
    child eval {set env(test) garbage}
    set names [array names env]
    interp delete child
    set ix [lsearch $names test]
    catch {unset env(test)}
    expr {$ix >= 0}
} {1}


# Some tests require the "exec" command.
# Skip them if exec is not defined.
set ::tcltest::testConfig(execCommandExists) [expr {[info commands exec] != ""}]









set f [open printenv w]
puts $f {
    proc lrem {listname name} {
	upvar $listname list
	set i [lsearch $list $name]
	if {$i >= 0} {
	    set list [lreplace $list $i $i]
................................................................................
# ('saved' env vars)
foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH DISPLAY SHLIB_PATH} {
  if {[info exists env2($name)]} {
     set env($name) $env2($name);
  }
}

test env-2.1 {adding environment variables} {execCommandExists} {
    getenv
} {}

set env(NAME1) "test string"
test env-2.2 {adding environment variables} {execCommandExists} {
    getenv
} {NAME1=test string}

set env(NAME2) "more"
test env-2.3 {adding environment variables} {execCommandExists} {
    getenv
} {NAME1=test string
NAME2=more}

set env(XYZZY) "garbage"
test env-2.4 {adding environment variables} {execCommandExists} {
    getenv
} {NAME1=test string
NAME2=more
XYZZY=garbage}

set env(NAME2) "new value"
test env-3.1 {changing environment variables} {execCommandExists} {
    set result [getenv]
    unset env(NAME2)
    set result
} {NAME1=test string
NAME2=new value
XYZZY=garbage}


test env-4.1 {unsetting environment variables} {execCommandExists} {
    set result [getenv]
    unset env(NAME1)
    set result
} {NAME1=test string
XYZZY=garbage}


test env-4.2 {unsetting environment variables} {execCommandExists} {
    set result [getenv]

    unset env(XYZZY)
    set result
} {XYZZY=garbage}

test env-4.3 {setting international environment variables} {execCommandExists} {
    set env(\ua7) \ub6
    getenv
} "\ua7=\ub6"
test env-4.4 {changing international environment variables} {execCommandExists} {
    set env(\ua7) \ua7
    getenv
} "\ua7=\ua7"
test env-4.5 {unsetting international environment variables} {execCommandExists} {
    set env(\ub6) \ua7
    unset env(\ua7)
    set result [getenv]

    unset env(\ub6)
    set result
} "\ub6=\ua7"

# Restore the environment variables at the end of the test.

foreach name [array names env] {
    unset env($name)
}
foreach name [array names env2] {
    set env($name) $env2($name)
}

# cleanup
file delete printenv
::tcltest::cleanupTests
return











Changes to tests/error.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
172
173
174
175
176
177
178
179
180
181










# 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.
#
# RCS: @(#) $Id: error.test,v 1.1.2.3 1999/03/11 18:49:33 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc foo {} {
    global errorInfo
    set a [catch {format [error glorp2]} b]
    error {Human-generated}
................................................................................
test error-6.1 {catch must reset error state} {
    catch {error outer [catch {error inner inner.errorInfo inner.errorCode}]}
    list $errorCode $errorInfo
} {NONE 1}

# cleanup
catch {rename p ""}
::test::cleanupTests
return 

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
# 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.
#
# RCS: @(#) $Id: error.test,v 1.1.2.4 1999/03/23 20:06:18 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc foo {} {
    global errorInfo
    set a [catch {format [error glorp2]} b]
    error {Human-generated}
................................................................................
test error-6.1 {catch must reset error state} {
    catch {error outer [catch {error inner inner.errorInfo inner.errorCode}]}
    list $errorCode $errorInfo
} {NONE 1}

# cleanup
catch {rename p ""}
::tcltest::cleanupTests
return 











Changes to tests/eval.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
54
55
56
57
58
59
60
61
62
63










# 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.
#
# RCS: @(#) $Id: eval.test,v 1.1.2.3 1999/03/11 18:49:33 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test eval-1.1 {single argument} {
    eval {format 22}
} 22
test eval-1.2 {multiple arguments} {
................................................................................
    invoked from within
\"eval {
	set a 1
	error \"test error\"
    }\""

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
# 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.
#
# RCS: @(#) $Id: eval.test,v 1.1.2.4 1999/03/23 20:06:19 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test eval-1.1 {single argument} {
    eval {format 22}
} 22
test eval-1.2 {multiple arguments} {
................................................................................
    invoked from within
\"eval {
	set a 1
	error \"test error\"
    }\""

# cleanup
::tcltest::cleanupTests
return











Changes to tests/event.test.

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
565
566
567
568
569
570
571
572
573
574










#
# 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.
#
# RCS: @(#) $Id: event.test,v 1.1.2.3 1999/03/11 18:49:34 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {testfilehandler create 0 off off}] == 0 } {
    test event-1.1 {Tcl_CreateFileHandler, reading} {
	testfilehandler close
	testfilehandler create 0 readable off
................................................................................
    } {{} readable}
}

# cleanup
foreach i [after info] {
    after cancel $i
}
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
#
# 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.
#
# RCS: @(#) $Id: event.test,v 1.1.2.4 1999/03/23 20:06:19 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {testfilehandler create 0 off off}] == 0 } {
    test event-1.1 {Tcl_CreateFileHandler, reading} {
	testfilehandler close
	testfilehandler create 0 readable off
................................................................................
    } {{} readable}
}

# cleanup
foreach i [after info] {
    after cancel $i
}
::tcltest::cleanupTests
return











Changes to tests/exec.test.

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
...
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
...
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
...
572
573
574
575
576
577
578
579
580
581










# Copyright (c) 1991-1994 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: exec.test,v 1.1.2.3 1999/03/11 18:49:34 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}


# If exec is not defined just return with no error
# Some platforms like the Macintosh do not have the exec command
if {[info commands exec] == ""} {
    puts "exec not implemented for this machine"
    return
}
if {$::test::testConfig(stdio) == 0} {
    return
}

set f [open echo w]
puts $f {
    puts -nonewline [lindex $argv 0]
    foreach str [lrange $argv 1 end] {
	puts -nonewline " $str"
    }
................................................................................
puts $f {
    exit $argv
}
close $f

# Basic operations.

test exec-1.1 {basic exec operation} {
    exec $tcltest echo a b c
} "a b c"
test exec-1.2 {pipelining} {
    exec $tcltest echo a b c d | $tcltest cat | $tcltest cat
} "a b c d"
test exec-1.3 {pipelining} {
    set a [exec $tcltest echo a b c d | $tcltest cat | $tcltest wc]
    list [scan $a "%d %d %d" b c d] $b $c
} {3 1 4}
set arg {12345678901234567890123456789012345678901234567890}
set arg "$arg$arg$arg$arg$arg$arg"
test exec-1.4 {long command lines} {
    exec $tcltest echo $arg
} $arg
set arg {}

# I/O redirection: input from Tcl command.

test exec-2.1 {redirecting input from immediate source} {
    exec $tcltest cat << "Sample text"
} {Sample text}
test exec-2.2 {redirecting input from immediate source} {
    exec << "Sample text" $tcltest cat | $tcltest cat
} {Sample text}
test exec-2.3 {redirecting input from immediate source} {
    exec $tcltest cat << "Sample text" | $tcltest cat
} {Sample text}
test exec-2.4 {redirecting input from immediate source} {
    exec $tcltest cat | $tcltest cat << "Sample text"
} {Sample text}
test exec-2.5 {redirecting input from immediate source} {
    exec $tcltest cat "<<Joined to arrows"
} {Joined to arrows}

# I/O redirection: output to file.

file delete gorp.file
test exec-3.1 {redirecting output to file} {
    exec $tcltest echo "Some simple words" > gorp.file
    exec $tcltest cat gorp.file
} "Some simple words"
test exec-3.2 {redirecting output to file} {
    exec $tcltest echo "More simple words" | >gorp.file $tcltest cat | $tcltest cat
    exec $tcltest cat gorp.file
} "More simple words"
test exec-3.3 {redirecting output to file} {
    exec > gorp.file $tcltest echo "Different simple words" | $tcltest cat | $tcltest cat
    exec $tcltest cat gorp.file
} "Different simple words"
test exec-3.4 {redirecting output to file} {
    exec $tcltest echo "Some simple words" >gorp.file
    exec $tcltest cat gorp.file
} "Some simple words"
test exec-3.5 {redirecting output to file} {
    exec $tcltest echo "First line" >gorp.file
    exec $tcltest echo "Second line" >> gorp.file
    exec $tcltest cat gorp.file
} "First line\nSecond line"
test exec-3.6 {redirecting output to file} {
    exec $tcltest echo "First line" >gorp.file
    exec $tcltest echo "Second line" >>gorp.file
    exec $tcltest cat gorp.file
} "First line\nSecond line"
test exec-3.7 {redirecting output to file} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec $tcltest echo "More text" >@ $f
    exec $tcltest echo >@$f "Even more"
    puts $f "Line 3"
    close $f
    exec $tcltest cat gorp.file
} "Line 1\nMore text\nEven more\nLine 3"

# I/O redirection: output and stderr to file.

file delete gorp.file
test exec-4.1 {redirecting output and stderr to file} {
    exec $tcltest echo "test output" >& gorp.file
    exec $tcltest cat gorp.file
} "test output"
test exec-4.2 {redirecting output and stderr to file} {
    list [exec $tcltest sh -c "echo foo bar 1>&2" >&gorp.file] \
	    [exec $tcltest cat gorp.file]
} {{} {foo bar}}
test exec-4.3 {redirecting output and stderr to file} {
    exec $tcltest echo "first line" > gorp.file
    list [exec $tcltest sh -c "echo foo bar 1>&2" >>&gorp.file] \
	    [exec $tcltest cat gorp.file]
} "{} {first line\nfoo bar}"
test exec-4.4 {redirecting output and stderr to file} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec $tcltest echo "More text" >&@ $f
    exec $tcltest echo >&@$f "Even more"
    puts $f "Line 3"
    close $f
    exec $tcltest cat gorp.file
} "Line 1\nMore text\nEven more\nLine 3"
test exec-4.5 {redirecting output and stderr to file} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec >&@ $f $tcltest sh -c "echo foo bar 1>&2"
    exec >&@$f $tcltest sh -c "echo xyzzy 1>&2"
    puts $f "Line 3"
    close $f
    exec $tcltest cat gorp.file
} "Line 1\nfoo bar\nxyzzy\nLine 3"

# I/O redirection: input from file.

exec $tcltest echo "Just a few thoughts" > gorp.file
test exec-5.1 {redirecting input from file} {
    exec $tcltest cat < gorp.file
} {Just a few thoughts}
test exec-5.2 {redirecting input from file} {
    exec $tcltest cat | $tcltest cat < gorp.file
} {Just a few thoughts}
test exec-5.3 {redirecting input from file} {
    exec $tcltest cat < gorp.file | $tcltest cat
} {Just a few thoughts}
test exec-5.4 {redirecting input from file} {
    exec < gorp.file $tcltest cat | $tcltest cat
} {Just a few thoughts}
test exec-5.5 {redirecting input from file} {
    exec $tcltest cat <gorp.file
} {Just a few thoughts}
test exec-5.6 {redirecting input from file} {
    set f [open gorp.file r]
    set result [exec $tcltest cat <@ $f]
    close $f
    set result
} {Just a few thoughts}
test exec-5.7 {redirecting input from file} {
    set f [open gorp.file r]
    set result [exec <@$f $tcltest cat]
    close $f
    set result
} {Just a few thoughts}

# I/O redirection: standard error through a pipeline.

test exec-6.1 {redirecting stderr through a pipeline} {
    exec $tcltest sh -c "echo foo bar" |& $tcltest cat
} "foo bar"
test exec-6.2 {redirecting stderr through a pipeline} {
    exec $tcltest sh -c "echo foo bar 1>&2" |& $tcltest cat
} "foo bar"
test exec-6.3 {redirecting stderr through a pipeline} {
    exec $tcltest sh -c "echo foo bar 1>&2" \
	|& $tcltest sh -c "echo second msg 1>&2 ; cat" |& $tcltest cat
} "second msg\nfoo bar"

# I/O redirection: combinations.

file delete gorp.file2
test exec-7.1 {multiple I/O redirections} {
    exec << "command input" > gorp.file2 $tcltest cat < gorp.file
    exec $tcltest cat gorp.file2
} {Just a few thoughts}
test exec-7.2 {multiple I/O redirections} {
    exec < gorp.file << "command input" $tcltest cat
} {command input}

# Long input to command and output from command.

set a "0123456789 xxxxxxxxx abcdefghi ABCDEFGHIJK\n"
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
test exec-8.1 {long input and output} {
    exec $tcltest cat << $a
} $a

# More than 20 arguments to exec.

test exec-8.1 {long input and output} {
    exec $tcltest echo 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23}

# Commands that return errors.

test exec-9.1 {commands returning errors} {
    set x [catch {exec gorp456} msg]
    list $x [string tolower $msg] [string tolower $errorCode]
} {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}}
test exec-9.2 {commands returning errors} {
    string tolower [list [catch {exec $tcltest echo foo | foo123} msg] $msg $errorCode]
} {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}}
test exec-9.3 {commands returning errors} {
    list [catch {exec $tcltest sleep 1 | $tcltest exit 43 | $tcltest sleep 1} msg] $msg
} {1 {child process exited abnormally}}
test exec-9.4 {commands returning errors} {
    list [catch {exec $tcltest exit 43 | $tcltest echo "foo bar"} msg] $msg
} {1 {foo bar
child process exited abnormally}}
test exec-9.5 {commands returning errors} {
    list [catch {exec gorp456 | $tcltest echo a b c} msg] [string tolower $msg]
} {1 {couldn't execute "gorp456": no such file or directory}}
test exec-9.6 {commands returning errors} {
    list [catch {exec $tcltest sh -c "echo error msg 1>&2"} msg] $msg
} {1 {error msg}}
test exec-9.7 {commands returning errors} {
    list [catch {exec $tcltest sh -c "echo error msg 1>&2" \
		     | $tcltest sh -c "echo error msg 1>&2"} msg] $msg
} {1 {error msg
error msg}}
test exec-9.8 {commands returning errors} {
    set f [open err w]
    puts $f {
	puts stdout out
	puts stderr err
    }
    close $f
    list [catch {exec $tcltest err} msg] $msg
} {1 {out
err}}

# Errors in executing the Tcl command, as opposed to errors in the
# processes that are invoked.

test exec-10.1 {errors in exec invocation} {
    list [catch {exec} msg] $msg
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
test exec-10.2 {errors in exec invocation} {
    list [catch {exec | cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.3 {errors in exec invocation} {
    list [catch {exec cat |} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.4 {errors in exec invocation} {
    list [catch {exec cat | | cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.5 {errors in exec invocation} {
    list [catch {exec cat | |& cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.6 {errors in exec invocation} {
    list [catch {exec cat |&} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.7 {errors in exec invocation} {
    list [catch {exec cat <} msg] $msg
} {1 {can't specify "<" as last word in command}}
test exec-10.8 {errors in exec invocation} {
    list [catch {exec cat >} msg] $msg
} {1 {can't specify ">" as last word in command}}
test exec-10.9 {errors in exec invocation} {
    list [catch {exec cat <<} msg] $msg
} {1 {can't specify "<<" as last word in command}}
test exec-10.10 {errors in exec invocation} {
    list [catch {exec cat >>} msg] $msg
} {1 {can't specify ">>" as last word in command}}
test exec-10.11 {errors in exec invocation} {
    list [catch {exec cat >&} msg] $msg
} {1 {can't specify ">&" as last word in command}}
test exec-10.12 {errors in exec invocation} {
    list [catch {exec cat >>&} msg] $msg
} {1 {can't specify ">>&" as last word in command}}
test exec-10.13 {errors in exec invocation} {
    list [catch {exec cat >@} msg] $msg
} {1 {can't specify ">@" as last word in command}}
test exec-10.14 {errors in exec invocation} {
    list [catch {exec cat <@} msg] $msg
} {1 {can't specify "<@" as last word in command}}
test exec-10.15 {errors in exec invocation} {
    list [catch {exec cat < a/b/c} msg] [string tolower $msg]
} {1 {couldn't read file "a/b/c": no such file or directory}}
test exec-10.16 {errors in exec invocation} {
    list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
test exec-10.17 {errors in exec invocation} {
    list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
set f [open gorp.file w]
test exec-10.18 {errors in exec invocation} {
    list [catch {exec cat <@ $f} msg] $msg
} "1 {channel \"$f\" wasn't opened for reading}"
close $f
set f [open gorp.file r]
test exec-10.19 {errors in exec invocation} {
    list [catch {exec cat >@ $f} msg] $msg
} "1 {channel \"$f\" wasn't opened for writing}"
close $f
test exec-10.20 {errors in exec invocation} {
    list [catch {exec ~non_existent_user/foo/bar} msg] $msg
} {1 {user "non_existent_user" doesn't exist}}
test exec-10.21 {errors in exec invocation} {
    list [catch {exec $tcltest true | ~xyzzy_bad_user/x | false} msg] $msg
} {1 {user "xyzzy_bad_user" doesn't exist}}

# Commands in background.

test exec-11.1 {commands in background} {
    set x [lindex [time {exec $tcltest sleep 2 &}] 0]
    expr $x<1000000
} 1
test exec-11.2 {commands in background} {
    list [catch {exec $tcltest echo a &b} msg] $msg
} {0 {a &b}}
test exec-11.3 {commands in background} {
    llength [exec $tcltest sleep 1 &]
} 1
test exec-11.4 {commands in background} {
    llength [exec $tcltest sleep 1 | $tcltest sleep 1 | $tcltest sleep 1 &]
} 3
test exec-11.5 {commands in background} {
    set f [open gorp.file w]
    puts $f { catch { exec [info nameofexecutable] echo foo & } }
    close $f
    string compare "foo" [exec $tcltest gorp.file]
} 0

# Make sure that background commands are properly reaped when
# they eventually die.

exec $tcltest sleep 3
test exec-12.1 {reaping background processes} {unixOnly nonPortable} {

    for {set i 0} {$i < 20} {incr i} {
	exec echo foo > /dev/null &
    }
    exec sleep 1
    catch {exec ps | fgrep "echo foo" | fgrep -v fgrep | wc} msg
    lindex $msg 0
} 0
test exec-12.2 {reaping background processes} {unixOnly nonPortable} {

    exec sleep 2 | sleep 2 | sleep 2 &
    catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg
    set x [lindex $msg 0]
    exec sleep 3
    catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg
    list $x [lindex $msg 0]
} {3 0}
test exec-12.3 {reaping background processes} {unixOnly nonPortable} {

    exec sleep 1000 &
    exec sleep 1000 &
    set x [exec ps | fgrep "sleep" | fgrep -v fgrep]
    set pids {}
    foreach i [split $x \n] {
	lappend pids [lindex $i 0]
    }
................................................................................
    }
    catch {exec ps | fgrep "sleep" | fgrep -v fgrep | wc} msg
    list $x [lindex $msg 0]
} {2 0}

# Make sure "errorCode" is set correctly.

test exec-13.1 {setting errorCode variable} {
    list [catch {exec $tcltest cat < a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
test exec-13.2 {setting errorCode variable} {
    list [catch {exec $tcltest cat > a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
test exec-13.3 {setting errorCode variable} {
    set x [catch {exec _weird_cmd_} msg]
    list $x [string tolower $msg] [lindex $errorCode 0] \
	    [string tolower [lrange $errorCode 2 end]]
} {1 {couldn't execute "_weird_cmd_": no such file or directory} POSIX {{no such file or directory}}}

# Switches before the first argument

test exec-14.1 {-keepnewline switch} {
    exec -keepnewline $tcltest echo foo
} "foo\n"
test exec-14.2 {-keepnewline switch} {
    list [catch {exec -keepnewline} msg] $msg
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
test exec-14.3 {unknown switch} {
    list [catch {exec -gorp} msg] $msg
} {1 {bad switch "-gorp": must be -keepnewline or --}}
test exec-14.4 {-- switch} {
    list [catch {exec -- -gorp} msg] [string tolower $msg]
} {1 {couldn't execute "-gorp": no such file or directory}}

# Redirecting standard error separately from standard output

test exec-15.1 {standard error redirection} {
    exec $tcltest echo "First line" > gorp.file
    list [exec $tcltest sh -c "echo foo bar 1>&2" 2> gorp.file] \
	    [exec $tcltest cat gorp.file]
} {{} {foo bar}}
test exec-15.2 {standard error redirection} {
    list [exec $tcltest sh -c "echo foo bar 1>&2" \
		| $tcltest echo biz baz >gorp.file 2> gorp.file2] \
	    [exec $tcltest cat gorp.file] \
	    [exec $tcltest cat gorp.file2]
} {{} {biz baz} {foo bar}}
test exec-15.3 {standard error redirection} {
    list [exec $tcltest sh -c "echo foo bar 1>&2" \
	        | $tcltest echo biz baz 2>gorp.file > gorp.file2] \
	    [exec $tcltest cat gorp.file] \
	    [exec $tcltest cat gorp.file2]
} {{} {foo bar} {biz baz}}
test exec-15.4 {standard error redirection} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec $tcltest sh -c "echo foo bar 1>&2" 2>@ $f
    puts $f "Line 3"
    close $f
    exec $tcltest cat gorp.file
} {Line 1
foo bar
Line 3}
test exec-15.5 {standard error redirection} {
    exec $tcltest echo "First line" > gorp.file
    exec $tcltest sh -c "echo foo bar 1>&2" 2>> gorp.file
    exec $tcltest cat gorp.file
} {First line
foo bar}
test exec-15.6 {standard error redirection} {
    exec $tcltest sh -c "echo foo bar 1>&2" > gorp.file2 2> gorp.file \
	    >& gorp.file 2> gorp.file2 | $tcltest echo biz baz
    list [exec $tcltest cat gorp.file] [exec $tcltest cat gorp.file2]
} {{biz baz} {foo bar}}

test exec-16.1 {flush output before exec} {
    set f [open gorp.file w]
    puts $f "First line"
    exec $tcltest echo "Second line" >@ $f
    puts $f "Third line"
    close $f
    exec $tcltest cat gorp.file
} {First line
Second line
Third line}
test exec-16.2 {flush output before exec} {} {
    set f [open gorp.file w]
    puts $f "First line"
    exec $tcltest << {puts stderr {Second line}} >&@ $f > gorp.file2
    puts $f "Third line"
    close $f
    exec $tcltest cat gorp.file
} {First line
Second line
Third line}

test exec-17.1 { inheriting standard I/O } {
    set f [open script w]
    puts $f {close stdout
	set f [open gorp.file w]
	catch {exec [info nameofexecutable] echo foobar &}
	exec [info nameofexecutable] sleep 2
	close $f
    }
................................................................................
} {{foobar
}}

# cleanup
file delete script gorp.file gorp.file2
file delete echo cat wc sh sleep exit
file delete err
::test::cleanupTests
return

















|

|



>
|
<
|
<
<
<
<
<
<







 







|


|


|





|






|


|


|


|


|






|



|



|



|



|




|




|













|



|



|




|









|













|


|


|


|


|


|





|








|


|


|







|



|










|





|





|



|


|


|



|


|


|




|













|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|



|




|



|


|





|



|


|


|


|










|
>







|
>







|
>







 







|


|


|







|


|


|


|





|




|





|





|










|





|





|









|










|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21

22






23
24
25
26
27
28
29
..
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
...
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
...
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
# Copyright (c) 1991-1994 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: exec.test,v 1.1.2.4 1999/03/23 20:06:20 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# All tests require the "exec" command.
# Skip them if exec is not defined.

set ::tcltest::testConfig(execCommandExists) [expr {[info commands exec] != ""}]







set f [open echo w]
puts $f {
    puts -nonewline [lindex $argv 0]
    foreach str [lrange $argv 1 end] {
	puts -nonewline " $str"
    }
................................................................................
puts $f {
    exit $argv
}
close $f

# Basic operations.

test exec-1.1 {basic exec operation} {execCommandExists stdio} {
    exec $tcltest echo a b c
} "a b c"
test exec-1.2 {pipelining} {execCommandExists stdio} {
    exec $tcltest echo a b c d | $tcltest cat | $tcltest cat
} "a b c d"
test exec-1.3 {pipelining} {execCommandExists stdio} {
    set a [exec $tcltest echo a b c d | $tcltest cat | $tcltest wc]
    list [scan $a "%d %d %d" b c d] $b $c
} {3 1 4}
set arg {12345678901234567890123456789012345678901234567890}
set arg "$arg$arg$arg$arg$arg$arg"
test exec-1.4 {long command lines} {execCommandExists stdio} {
    exec $tcltest echo $arg
} $arg
set arg {}

# I/O redirection: input from Tcl command.

test exec-2.1 {redirecting input from immediate source} {execCommandExists stdio} {
    exec $tcltest cat << "Sample text"
} {Sample text}
test exec-2.2 {redirecting input from immediate source} {execCommandExists stdio} {
    exec << "Sample text" $tcltest cat | $tcltest cat
} {Sample text}
test exec-2.3 {redirecting input from immediate source} {execCommandExists stdio} {
    exec $tcltest cat << "Sample text" | $tcltest cat
} {Sample text}
test exec-2.4 {redirecting input from immediate source} {execCommandExists stdio} {
    exec $tcltest cat | $tcltest cat << "Sample text"
} {Sample text}
test exec-2.5 {redirecting input from immediate source} {execCommandExists stdio} {
    exec $tcltest cat "<<Joined to arrows"
} {Joined to arrows}

# I/O redirection: output to file.

file delete gorp.file
test exec-3.1 {redirecting output to file} {execCommandExists stdio} {
    exec $tcltest echo "Some simple words" > gorp.file
    exec $tcltest cat gorp.file
} "Some simple words"
test exec-3.2 {redirecting output to file} {execCommandExists stdio} {
    exec $tcltest echo "More simple words" | >gorp.file $tcltest cat | $tcltest cat
    exec $tcltest cat gorp.file
} "More simple words"
test exec-3.3 {redirecting output to file} {execCommandExists stdio} {
    exec > gorp.file $tcltest echo "Different simple words" | $tcltest cat | $tcltest cat
    exec $tcltest cat gorp.file
} "Different simple words"
test exec-3.4 {redirecting output to file} {execCommandExists stdio} {
    exec $tcltest echo "Some simple words" >gorp.file
    exec $tcltest cat gorp.file
} "Some simple words"
test exec-3.5 {redirecting output to file} {execCommandExists stdio} {
    exec $tcltest echo "First line" >gorp.file
    exec $tcltest echo "Second line" >> gorp.file
    exec $tcltest cat gorp.file
} "First line\nSecond line"
test exec-3.6 {redirecting output to file} {execCommandExists stdio} {
    exec $tcltest echo "First line" >gorp.file
    exec $tcltest echo "Second line" >>gorp.file
    exec $tcltest cat gorp.file
} "First line\nSecond line"
test exec-3.7 {redirecting output to file} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec $tcltest echo "More text" >@ $f
    exec $tcltest echo >@$f "Even more"
    puts $f "Line 3"
    close $f
    exec $tcltest cat gorp.file
} "Line 1\nMore text\nEven more\nLine 3"

# I/O redirection: output and stderr to file.

file delete gorp.file
test exec-4.1 {redirecting output and stderr to file} {execCommandExists stdio} {
    exec $tcltest echo "test output" >& gorp.file
    exec $tcltest cat gorp.file
} "test output"
test exec-4.2 {redirecting output and stderr to file} {execCommandExists stdio} {
    list [exec $tcltest sh -c "echo foo bar 1>&2" >&gorp.file] \
	    [exec $tcltest cat gorp.file]
} {{} {foo bar}}
test exec-4.3 {redirecting output and stderr to file} {execCommandExists stdio} {
    exec $tcltest echo "first line" > gorp.file
    list [exec $tcltest sh -c "echo foo bar 1>&2" >>&gorp.file] \
	    [exec $tcltest cat gorp.file]
} "{} {first line\nfoo bar}"
test exec-4.4 {redirecting output and stderr to file} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec $tcltest echo "More text" >&@ $f
    exec $tcltest echo >&@$f "Even more"
    puts $f "Line 3"
    close $f
    exec $tcltest cat gorp.file
} "Line 1\nMore text\nEven more\nLine 3"
test exec-4.5 {redirecting output and stderr to file} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec >&@ $f $tcltest sh -c "echo foo bar 1>&2"
    exec >&@$f $tcltest sh -c "echo xyzzy 1>&2"
    puts $f "Line 3"
    close $f
    exec $tcltest cat gorp.file
} "Line 1\nfoo bar\nxyzzy\nLine 3"

# I/O redirection: input from file.

exec $tcltest echo "Just a few thoughts" > gorp.file
test exec-5.1 {redirecting input from file} {execCommandExists stdio} {
    exec $tcltest cat < gorp.file
} {Just a few thoughts}
test exec-5.2 {redirecting input from file} {execCommandExists stdio} {
    exec $tcltest cat | $tcltest cat < gorp.file
} {Just a few thoughts}
test exec-5.3 {redirecting input from file} {execCommandExists stdio} {
    exec $tcltest cat < gorp.file | $tcltest cat
} {Just a few thoughts}
test exec-5.4 {redirecting input from file} {execCommandExists stdio} {
    exec < gorp.file $tcltest cat | $tcltest cat
} {Just a few thoughts}
test exec-5.5 {redirecting input from file} {execCommandExists stdio} {
    exec $tcltest cat <gorp.file
} {Just a few thoughts}
test exec-5.6 {redirecting input from file} {execCommandExists stdio} {
    set f [open gorp.file r]
    set result [exec $tcltest cat <@ $f]
    close $f
    set result
} {Just a few thoughts}
test exec-5.7 {redirecting input from file} {execCommandExists stdio} {
    set f [open gorp.file r]
    set result [exec <@$f $tcltest cat]
    close $f
    set result
} {Just a few thoughts}

# I/O redirection: standard error through a pipeline.

test exec-6.1 {redirecting stderr through a pipeline} {execCommandExists stdio} {
    exec $tcltest sh -c "echo foo bar" |& $tcltest cat
} "foo bar"
test exec-6.2 {redirecting stderr through a pipeline} {execCommandExists stdio} {
    exec $tcltest sh -c "echo foo bar 1>&2" |& $tcltest cat
} "foo bar"
test exec-6.3 {redirecting stderr through a pipeline} {execCommandExists stdio} {
    exec $tcltest sh -c "echo foo bar 1>&2" \
	|& $tcltest sh -c "echo second msg 1>&2 ; cat" |& $tcltest cat
} "second msg\nfoo bar"

# I/O redirection: combinations.

file delete gorp.file2
test exec-7.1 {multiple I/O redirections} {execCommandExists stdio} {
    exec << "command input" > gorp.file2 $tcltest cat < gorp.file
    exec $tcltest cat gorp.file2
} {Just a few thoughts}
test exec-7.2 {multiple I/O redirections} {execCommandExists stdio} {
    exec < gorp.file << "command input" $tcltest cat
} {command input}

# Long input to command and output from command.

set a "0123456789 xxxxxxxxx abcdefghi ABCDEFGHIJK\n"
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
test exec-8.1 {long input and output} {execCommandExists stdio} {
    exec $tcltest cat << $a
} $a

# More than 20 arguments to exec.

test exec-8.1 {long input and output} {execCommandExists stdio} {
    exec $tcltest echo 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23}

# Commands that return errors.

test exec-9.1 {commands returning errors} {execCommandExists stdio} {
    set x [catch {exec gorp456} msg]
    list $x [string tolower $msg] [string tolower $errorCode]
} {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}}
test exec-9.2 {commands returning errors} {execCommandExists stdio} {
    string tolower [list [catch {exec $tcltest echo foo | foo123} msg] $msg $errorCode]
} {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}}
test exec-9.3 {commands returning errors} {execCommandExists stdio} {
    list [catch {exec $tcltest sleep 1 | $tcltest exit 43 | $tcltest sleep 1} msg] $msg
} {1 {child process exited abnormally}}
test exec-9.4 {commands returning errors} {execCommandExists stdio} {
    list [catch {exec $tcltest exit 43 | $tcltest echo "foo bar"} msg] $msg
} {1 {foo bar
child process exited abnormally}}
test exec-9.5 {commands returning errors} {execCommandExists stdio} {
    list [catch {exec gorp456 | $tcltest echo a b c} msg] [string tolower $msg]
} {1 {couldn't execute "gorp456": no such file or directory}}
test exec-9.6 {commands returning errors} {execCommandExists stdio} {
    list [catch {exec $tcltest sh -c "echo error msg 1>&2"} msg] $msg
} {1 {error msg}}
test exec-9.7 {commands returning errors} {execCommandExists stdio} {
    list [catch {exec $tcltest sh -c "echo error msg 1>&2" \
		     | $tcltest sh -c "echo error msg 1>&2"} msg] $msg
} {1 {error msg
error msg}}
test exec-9.8 {commands returning errors} {execCommandExists stdio} {
    set f [open err w]
    puts $f {
	puts stdout out
	puts stderr err
    }
    close $f
    list [catch {exec $tcltest err} msg] $msg
} {1 {out
err}}

# Errors in executing the Tcl command, as opposed to errors in the
# processes that are invoked.

test exec-10.1 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec} msg] $msg
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
test exec-10.2 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec | cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.3 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat |} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.4 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat | | cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.5 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat | |& cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.6 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat |&} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.7 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat <} msg] $msg
} {1 {can't specify "<" as last word in command}}
test exec-10.8 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat >} msg] $msg
} {1 {can't specify ">" as last word in command}}
test exec-10.9 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat <<} msg] $msg
} {1 {can't specify "<<" as last word in command}}
test exec-10.10 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat >>} msg] $msg
} {1 {can't specify ">>" as last word in command}}
test exec-10.11 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat >&} msg] $msg
} {1 {can't specify ">&" as last word in command}}
test exec-10.12 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat >>&} msg] $msg
} {1 {can't specify ">>&" as last word in command}}
test exec-10.13 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat >@} msg] $msg
} {1 {can't specify ">@" as last word in command}}
test exec-10.14 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat <@} msg] $msg
} {1 {can't specify "<@" as last word in command}}
test exec-10.15 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat < a/b/c} msg] [string tolower $msg]
} {1 {couldn't read file "a/b/c": no such file or directory}}
test exec-10.16 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
test exec-10.17 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
set f [open gorp.file w]
test exec-10.18 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat <@ $f} msg] $msg
} "1 {channel \"$f\" wasn't opened for reading}"
close $f
set f [open gorp.file r]
test exec-10.19 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat >@ $f} msg] $msg
} "1 {channel \"$f\" wasn't opened for writing}"
close $f
test exec-10.20 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec ~non_existent_user/foo/bar} msg] $msg
} {1 {user "non_existent_user" doesn't exist}}
test exec-10.21 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec $tcltest true | ~xyzzy_bad_user/x | false} msg] $msg
} {1 {user "xyzzy_bad_user" doesn't exist}}

# Commands in background.

test exec-11.1 {commands in background} {execCommandExists stdio} {
    set x [lindex [time {exec $tcltest sleep 2 &}] 0]
    expr $x<1000000
} 1
test exec-11.2 {commands in background} {execCommandExists stdio} {
    list [catch {exec $tcltest echo a &b} msg] $msg
} {0 {a &b}}
test exec-11.3 {commands in background} {execCommandExists stdio} {
    llength [exec $tcltest sleep 1 &]
} 1
test exec-11.4 {commands in background} {execCommandExists stdio} {
    llength [exec $tcltest sleep 1 | $tcltest sleep 1 | $tcltest sleep 1 &]
} 3
test exec-11.5 {commands in background} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f { catch { exec [info nameofexecutable] echo foo & } }
    close $f
    string compare "foo" [exec $tcltest gorp.file]
} 0

# Make sure that background commands are properly reaped when
# they eventually die.

exec $tcltest sleep 3
test exec-12.1 {reaping background processes} \
	{execCommandExists stdio unixOnly nonPortable} {
    for {set i 0} {$i < 20} {incr i} {
	exec echo foo > /dev/null &
    }
    exec sleep 1
    catch {exec ps | fgrep "echo foo" | fgrep -v fgrep | wc} msg
    lindex $msg 0
} 0
test exec-12.2 {reaping background processes} \
	{execCommandExists stdio unixOnly nonPortable} {
    exec sleep 2 | sleep 2 | sleep 2 &
    catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg
    set x [lindex $msg 0]
    exec sleep 3
    catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg
    list $x [lindex $msg 0]
} {3 0}
test exec-12.3 {reaping background processes} \
	{execCommandExists stdio unixOnly nonPortable} {
    exec sleep 1000 &
    exec sleep 1000 &
    set x [exec ps | fgrep "sleep" | fgrep -v fgrep]
    set pids {}
    foreach i [split $x \n] {
	lappend pids [lindex $i 0]
    }
................................................................................
    }
    catch {exec ps | fgrep "sleep" | fgrep -v fgrep | wc} msg
    list $x [lindex $msg 0]
} {2 0}

# Make sure "errorCode" is set correctly.

test exec-13.1 {setting errorCode variable} {execCommandExists stdio} {
    list [catch {exec $tcltest cat < a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
test exec-13.2 {setting errorCode variable} {execCommandExists stdio} {
    list [catch {exec $tcltest cat > a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
test exec-13.3 {setting errorCode variable} {execCommandExists stdio} {
    set x [catch {exec _weird_cmd_} msg]
    list $x [string tolower $msg] [lindex $errorCode 0] \
	    [string tolower [lrange $errorCode 2 end]]
} {1 {couldn't execute "_weird_cmd_": no such file or directory} POSIX {{no such file or directory}}}

# Switches before the first argument

test exec-14.1 {-keepnewline switch} {execCommandExists stdio} {
    exec -keepnewline $tcltest echo foo
} "foo\n"
test exec-14.2 {-keepnewline switch} {execCommandExists stdio} {
    list [catch {exec -keepnewline} msg] $msg
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
test exec-14.3 {unknown switch} {execCommandExists stdio} {
    list [catch {exec -gorp} msg] $msg
} {1 {bad switch "-gorp": must be -keepnewline or --}}
test exec-14.4 {-- switch} {execCommandExists stdio} {
    list [catch {exec -- -gorp} msg] [string tolower $msg]
} {1 {couldn't execute "-gorp": no such file or directory}}

# Redirecting standard error separately from standard output

test exec-15.1 {standard error redirection} {execCommandExists stdio} {
    exec $tcltest echo "First line" > gorp.file
    list [exec $tcltest sh -c "echo foo bar 1>&2" 2> gorp.file] \
	    [exec $tcltest cat gorp.file]
} {{} {foo bar}}
test exec-15.2 {standard error redirection} {execCommandExists stdio} {
    list [exec $tcltest sh -c "echo foo bar 1>&2" \
		| $tcltest echo biz baz >gorp.file 2> gorp.file2] \
	    [exec $tcltest cat gorp.file] \
	    [exec $tcltest cat gorp.file2]
} {{} {biz baz} {foo bar}}
test exec-15.3 {standard error redirection} {execCommandExists stdio} {
    list [exec $tcltest sh -c "echo foo bar 1>&2" \
	        | $tcltest echo biz baz 2>gorp.file > gorp.file2] \
	    [exec $tcltest cat gorp.file] \
	    [exec $tcltest cat gorp.file2]
} {{} {foo bar} {biz baz}}
test exec-15.4 {standard error redirection} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec $tcltest sh -c "echo foo bar 1>&2" 2>@ $f
    puts $f "Line 3"
    close $f
    exec $tcltest cat gorp.file
} {Line 1
foo bar
Line 3}
test exec-15.5 {standard error redirection} {execCommandExists stdio} {
    exec $tcltest echo "First line" > gorp.file
    exec $tcltest sh -c "echo foo bar 1>&2" 2>> gorp.file
    exec $tcltest cat gorp.file
} {First line
foo bar}
test exec-15.6 {standard error redirection} {execCommandExists stdio} {
    exec $tcltest sh -c "echo foo bar 1>&2" > gorp.file2 2> gorp.file \
	    >& gorp.file 2> gorp.file2 | $tcltest echo biz baz
    list [exec $tcltest cat gorp.file] [exec $tcltest cat gorp.file2]
} {{biz baz} {foo bar}}

test exec-16.1 {flush output before exec} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f "First line"
    exec $tcltest echo "Second line" >@ $f
    puts $f "Third line"
    close $f
    exec $tcltest cat gorp.file
} {First line
Second line
Third line}
test exec-16.2 {flush output before exec} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f "First line"
    exec $tcltest << {puts stderr {Second line}} >&@ $f > gorp.file2
    puts $f "Third line"
    close $f
    exec $tcltest cat gorp.file
} {First line
Second line
Third line}

test exec-17.1 { inheriting standard I/O } {execCommandExists stdio} {
    set f [open script w]
    puts $f {close stdout
	set f [open gorp.file w]
	catch {exec [info nameofexecutable] echo foobar &}
	exec [info nameofexecutable] sleep 2
	close $f
    }
................................................................................
} {{foobar
}}

# cleanup
file delete script gorp.file gorp.file2
file delete echo cat wc sh sleep exit
file delete err
::tcltest::cleanupTests
return











Changes to tests/execute.test.

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
...
111
112
113
114
115
116
117
118
119
120










#
# 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.
#
# RCS: @(#) $Id: execute.test,v 1.1.2.3 1999/03/11 18:49:35 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
catch {unset y}
................................................................................
catch {rename foo ""}
catch {rename p ""}
catch {rename {} ""}
catch {rename { } ""}
catch {unset x}
catch {unset y}
catch {unset msg}
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
...
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
#
# 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.
#
# RCS: @(#) $Id: execute.test,v 1.1.2.4 1999/03/23 20:06:20 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
catch {unset y}
................................................................................
catch {rename foo ""}
catch {rename p ""}
catch {rename {} ""}
catch {rename { } ""}
catch {unset x}
catch {unset y}
catch {unset msg}
::tcltest::cleanupTests
return











Changes to tests/expr-old.test.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
928
929
930
931
932
933
934
935
936
937










# Copyright (c) 1991-1994 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: expr-old.test,v 1.1.2.3 1999/03/11 18:49:35 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    set gotT1 0
    puts "This application hasn't been compiled with the \"T1\" and"
    puts "\"T2\" math functions, so I'll skip some of the expr tests."
................................................................................
    puts "Warning: this machine contains a defective Pentium processor"
    puts "that performs arithmetic incorrectly.  I recommend that you"
    puts "call Intel customer service immediately at 1-800-628-8686"
    puts "to request a replacement processor."
}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
# Copyright (c) 1991-1994 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: expr-old.test,v 1.1.2.4 1999/03/23 20:06:21 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    set gotT1 0
    puts "This application hasn't been compiled with the \"T1\" and"
    puts "\"T2\" math functions, so I'll skip some of the expr tests."
................................................................................
    puts "Warning: this machine contains a defective Pentium processor"
    puts "that performs arithmetic incorrectly.  I recommend that you"
    puts "call Intel customer service immediately at 1-800-628-8686"
    puts "to request a replacement processor."
}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/expr.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
665
666
667
668
669
670
671
672
673
674










#
# 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.
#
# RCS: @(#) $Id: expr.test,v 1.1.2.3 1999/03/11 18:49:36 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    set gotT1 0
    puts "This application hasn't been compiled with the \"T1\" and"
    puts "\"T2\" math functions, so I'll skip some of the expr tests."
................................................................................
        set y  [expr round($x)]
    }
    p
} 3

# cleanup
unset a
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
#
# 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.
#
# RCS: @(#) $Id: expr.test,v 1.1.2.4 1999/03/23 20:06:21 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    set gotT1 0
    puts "This application hasn't been compiled with the \"T1\" and"
    puts "\"T2\" math functions, so I'll skip some of the expr tests."
................................................................................
        set y  [expr round($x)]
    }
    p
} 3

# cleanup
unset a
::tcltest::cleanupTests
return











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
22
23
24
25
26
27
28
29
30
31
32
33
34
35












36
37
38
39
40
41
42
..
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
...
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
...
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
...
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
...
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
...
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
...
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
...
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
...
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
...
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
....
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
....
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
....
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
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
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368

1369
1370
1371
1372
1373
1374
1375
1376
1377
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
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
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
....
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
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
....
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
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
1665
1666
1667
1668
1669

1670
1671
1672
1673
1674
1675
1676
....
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
1703
1704
1705
....
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
....
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
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
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
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
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
....
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983

1984
1985
1986
1987
1988
1989
1990
1991
1992
1993

1994
1995
1996
1997
1998
1999
2000
2001
2002
2003

2004
2005
2006
2007
2008
2009
2010
....
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
....
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
....
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
....
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










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

#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: fCmd.test,v 1.1.2.5 1999/03/11 18:49:36 hershey Exp $
#

if {[string compare test [info procs test]] == 1} then {source defs}



if {[string compare testgetplatform [info commands testgetplatform]] != 0} {
    puts "This application hasn't been compiled with the \"testgetplatform\""
    puts "command, therefore I am skipping all of these tests."
    return
}

set platform [testgetplatform]

if {$user == "root"} {
    puts "Skipping fCmd tests.  They depend on not being able to write to"
    puts "certain directories.  It would be too dangerous to run them as root."
    return
}

if {"[info commands testchmod]" != "testchmod"} {
    puts "Skipping fCmd tests. This application does not seem to have the"
    puts "testchmod command that is needed to run these tests."
    return
}













proc createfile {file {string a}} {
    set f [open $file w]
    puts -nonewline $f $string
    close $f
    return $string
}
................................................................................
proc contents {file} {
    set f [open $file r]
    set r [read $f]
    close $f
    set r
}

set ::test::testConfig(NT) 0
set ::test::testConfig(95) 0

switch $tcl_platform(os) {
    "Windows NT" {set ::test::testConfig(NT) 1}
    "Windows 95" {set ::test::testConfig(95) 1}
}

set ::test::testConfig(fileSharing) 0
set ::test::testConfig(notFileSharing) 1

if {$tcl_platform(platform) == "macintosh"} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    if {[catch {file attributes foo.dir -readonly 1}] == 0} {
    	set ::test::testConfig(fileSharing) 1
    	set ::test::testConfig(notFileSharing) 0
    }
    file delete -force foo.dir
}

set ::test::testConfig(xdev) 0

if {$tcl_platform(platform) == "unix"} {
    if {[catch {set m1 [exec df .]; set m2 [exec df /tmp]}] == 0} {
	set m1 [string range $m1 0 [expr [string first " " $m1]-1]]
	set m2 [string range $m2 0 [expr [string first " " $m2]-1]]
	if {$m1 != "" && $m2 != "" && $m1 != $m2 && [file exists $m1] && [file exists $m2]} {
	    set ::test::testConfig(xdev) 1
	}
    }
}

set root [lindex [file split [pwd]] 0]

# A really long file name
................................................................................
set long "abcdefghihjllmnopqrstuvwxyz01234567890"
append long $long
append long $long
append long $long
append long $long
append long $long

test fCmd-1.1 {TclFileRenameCmd} {
    cleanup
    createfile tf1
    file rename tf1 tf2
    glob tf*
} {tf2}

test fCmd-2.1 {TclFileCopyCmd} {
    cleanup
    createfile tf1
    file copy tf1 tf2
    lsort [glob tf*]
} {tf1 tf2}

test fCmd-3.1 {FileCopyRename: FileForceOption fails} {
    list [catch {file rename -xyz} msg] $msg
} {1 {bad option "-xyz": should be -force or --}}
test fCmd-3.2 {FileCopyRename: not enough args} {
    list [catch {file rename xyz} msg] $msg
} {1 {wrong # args: should be "file rename ?options? source ?source ...? target"}}
test fCmd-3.3 {FileCopyRename: Tcl_TranslateFileName fails} {
    list [catch {file rename xyz ~nonexistantuser} msg] $msg
} {1 {user "nonexistantuser" doesn't exist}}
test fCmd-3.4 {FileCopyRename: Tcl_TranslateFileName passes} {
    cleanup
    list [catch {file copy tf1 ~} msg] $msg
} {1 {error copying "tf1": no such file or directory}}
test fCmd-3.5 {FileCopyRename: target doesn't exist: stat(target) != 0} {
    cleanup
    list [catch {file rename tf1 tf2 tf3} msg] $msg
} {1 {error renaming: target "tf3" is not a directory}}
test fCmd-3.6 {FileCopyRename: target tf3 is not a directory: !S_ISDIR(target)} {

    cleanup
    createfile tf3
    list [catch {file rename tf1 tf2 tf3} msg] $msg
} {1 {error renaming: target "tf3" is not a directory}}
test fCmd-3.7 {FileCopyRename: target exists & is directory} {
    cleanup
    file mkdir td1
    createfile tf1 tf1
    file rename tf1 td1
    contents [file join td1 tf1]
} {tf1}
test fCmd-3.8 {FileCopyRename: too many arguments: argc - i > 2} {
    cleanup
    list [catch {file rename tf1 tf2 tf3} msg] $msg
} {1 {error renaming: target "tf3" is not a directory}}
test fCmd-3.9 {FileCopyRename: too many arguments: argc - i > 2} {
    cleanup
    list [catch {file copy -force -- tf1 tf2 tf3} msg] $msg
} {1 {error copying: target "tf3" is not a directory}}
test fCmd-3.10 {FileCopyRename: just 2 arguments} {
    cleanup
    createfile tf1 tf1
    file rename tf1 tf2
    contents tf2
} {tf1}
test fCmd-3.11 {FileCopyRename: just 2 arguments} {
    cleanup
    createfile tf1 tf1
    file rename -force -force -- tf1 tf2
    contents tf2
} {tf1}
test fCmd-3.12 {FileCopyRename: move each source: 1 source} {
    cleanup
    createfile tf1 tf1
    file mkdir td1
    file rename tf1 td1
    contents [file join td1 tf1]
} {tf1}
test fCmd-3.13 {FileCopyRename: move each source: multiple sources} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    createfile tf3 tf3
    createfile tf4 tf4
    file mkdir td1
    file rename tf1 tf2 tf3 tf4 td1
    list [contents [file join td1 tf1]] [contents [file join td1 tf2]] \
	[contents [file join td1 tf3]] [contents [file join td1 tf4]]
} {tf1 tf2 tf3 tf4}
test fCmd-3.14 {FileCopyRename: FileBasename fails} {
    cleanup
    file mkdir td1
    list [catch {file rename ~nonexistantuser td1} msg] $msg
} {1 {user "nonexistantuser" doesn't exist}}
test fCmd-3.15 {FileCopyRename: source[0] == '\0'} {unixOrPc} {
    cleanup
    file mkdir td1
    list [catch {file rename / td1} msg] $msg
} {1 {error renaming "/" to "td1": file already exists}}
test fCmd-3.16 {FileCopyRename: break on first error} {
    cleanup
    createfile tf1 
    createfile tf2 
    createfile tf3 
    createfile tf4 
    file mkdir td1
    createfile [file join td1 tf3]
    list [catch {file rename tf1 tf2 tf3 tf4 td1} msg] $msg
} [subst {1 {error renaming "tf3" to "[file join td1 tf3]": file already exists}}]

test fCmd-4.1 {TclFileMakeDirsCmd: make each dir: 1 dir} {
    cleanup
    file mkdir td1
    glob td*
} {td1}
test fCmd-4.2 {TclFileMakeDirsCmd: make each dir: multiple dirs} {
    cleanup
    file mkdir td1 td2 td3
    lsort [glob td*]
} {td1 td2 td3}
test fCmd-4.3 {TclFileMakeDirsCmd: stops on first error} {
    cleanup
    createfile tf1
    catch {file mkdir td1 td2 tf1 td3 td4}
    glob td1 td2 tf1 td3 td4
} {td1 td2 tf1}
test fCmd-4.4 {TclFileMakeDirsCmd: Tcl_TranslateFileName fails} {
    cleanup
    list [catch {file mkdir ~nonexistantuser} msg] $msg
} {1 {user "nonexistantuser" doesn't exist}}
test fCmd-4.5 {TclFileMakeDirsCmd: Tcl_SplitPath returns 0: *name == '\0'} {

    cleanup
    list [catch {file mkdir ""} msg] $msg
} {1 {can't create directory "": no such file or directory}}
test fCmd-4.6 {TclFileMakeDirsCmd: one level deep} {
    cleanup
    file mkdir td1
    glob td1
} {td1}
test fCmd-4.7 {TclFileMakeDirsCmd: multi levels deep} {
    cleanup
    file mkdir [file join td1 td2 td3 td4]
    glob td1 [file join td1 td2]
} "td1 [file join td1 td2]"
test fCmd-4.8 {TclFileMakeDirsCmd: already exist: lstat(target) == 0} {












    cleanup
    file mkdir td1
    set x [file exist td1]
    file mkdir td1
    list $x [file exist td1]
} {1 1}
test fCmd-4.9 {TclFileMakeDirsCmd: exists, not dir} {
    cleanup
    createfile tf1
    list [catch {file mkdir tf1} msg] $msg
} [subst {1 {can't create directory "[file join tf1]": file already exists}}]
test fCmd-4.10 {TclFileMakeDirsCmd: exists, is dir} {
    cleanup
    file mkdir td1
    set x [file exist td1]
    file mkdir td1
    list $x [file exist td1]
} {1 1}
test fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} {unixOnly} {

    cleanup
    file mkdir td1/td2/td3
    testchmod 000 td1/td2
    set msg [list [catch {file mkdir td1/td2/td3/td4} msg] $msg]
    testchmod 755 td1/td2
    set msg
} {1 {can't create directory "td1/td2/td3": permission denied}}
test fCmd-4.12 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} {macOnly} {
    cleanup
    list [catch {file mkdir nonexistantvolume:} msg] $msg
} {1 {can't create directory "nonexistantvolume:": invalid argument}}
test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} {
    cleanup
    set x [file exist td1]
    file mkdir td1
    list $x [file exist td1]
} {0 1}
test fCmd-4.14 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {unixOnly} {

    cleanup
    file delete -force foo
    file mkdir foo
    file attr foo -perm 040000
    set result [list [catch {file mkdir foo/tf1} msg] $msg]
    file delete -force foo
    set result
} {1 {can't create directory "foo/tf1": permission denied}}
test fCmd-4.15 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {macOnly} {
    list [catch {file mkdir ${root}:} msg] $msg
} [subst {1 {can't create directory "${root}:": no such file or directory}}]
test fCmd-4.16 {TclFileMakeDirsCmd: TclpCreateDirectory succeeds} {
    cleanup
    file mkdir tf1
    file exists tf1
} {1}

test fCmd-5.1 {TclFileDeleteCmd: FileForceOption fails} {
    list [catch {file delete -xyz} msg] $msg
} {1 {bad option "-xyz": should be -force or --}}
test fCmd-5.2 {TclFileDeleteCmd: not enough args} {
    list [catch {file delete -force -force} msg] $msg
} {1 {wrong # args: should be "file delete ?options? file ?file ...?"}}
test fCmd-5.3 {TclFileDeleteCmd: 1 file} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    file delete tf2
    glob tf* td*
} {tf1 td1}
test fCmd-5.4 {TclFileDeleteCmd: multiple files} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    set x [list [file exist tf1] [file exist tf2] [file exist td1]]
    file delete tf1 td1 tf2
    lappend x [file exist tf1] [file exist tf2] [file exist tf3]
} {1 1 1 0 0 0}
test fCmd-5.5 {TclFileDeleteCmd: stop at first error} {unixOrPc} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    catch {file delete tf1 td1 $root tf2}
    list [file exist tf1] [file exist tf2] [file exist td1]
} {0 1 0}
test fCmd-5.6 {TclFileDeleteCmd: Tcl_TranslateFileName fails} {
    list [catch {file delete ~nonexistantuser} msg] $msg
} {1 {user "nonexistantuser" doesn't exist}}
test fCmd-5.7 {TclFileDeleteCmd: Tcl_TranslateFileName succeeds} {
    catch {file delete ~/tf1}
    createfile ~/tf1
    file delete ~/tf1
} {}
test fCmd-5.8 {TclFileDeleteCmd: file doesn't exist: lstat(name) != 0} {
    cleanup
    set x [file exist tf1]
    file delete tf1
    list $x [file exist tf1]
} {0 0}    
test fCmd-5.9 {TclFileDeleteCmd: is directory} {
    cleanup
    file mkdir td1
    file delete td1
    file exist td1
} {0}
test fCmd-5.10 {TclFileDeleteCmd: TclpRemoveDirectory fails} {
    cleanup
    file mkdir td1/td2
    list [catch {file delete td1} msg] $msg
} {1 {error deleting "td1": directory not empty}}

test fCmd-6.1 {CopyRenameOneFile: bad source} {
    # can't test this, because it's caught by FileCopyRename
} {}
test fCmd-6.2 {CopyRenameOneFile: bad target} {
    # can't test this, because it's caught by FileCopyRename
} {}
test fCmd-6.3 {CopyRenameOneFile: lstat(source) != 0} {
    cleanup
    list [catch {file rename tf1 tf2} msg] $msg
} {1 {error renaming "tf1": no such file or directory}}
test fCmd-6.4 {CopyRenameOneFile: lstat(source) == 0} {






    cleanup
    createfile tf1
    file rename tf1 tf2
    glob tf*
} {tf2}
test fCmd-6.5 {CopyRenameOneFile: lstat(target) != 0} {
    cleanup
    createfile tf1
    file rename tf1 tf2
    glob tf*
} {tf2}
test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} {unixOnly} {
    cleanup
    file mkdir td1
    testchmod 000 td1
    createfile tf1
    set msg [list [catch {file rename tf1 td1} msg] $msg]
    testchmod 755 td1
    set msg
................................................................................
    list [catch {file rename tf1 $long} msg] $msg
} [subst {1 {error renaming "tf1" to "$long": file name too long}}]
test fCmd-6.8 {CopyRenameOneFile: errno != ENOENT} {macOnly} {
    cleanup
    createfile tf1
    list [catch {file rename tf1 $long} msg] $msg
} [subst {1 {error renaming "tf1" to "$long": file name too long}}]
test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} {unixOnly} {
    cleanup
    createfile tf1
    file rename tf1 tf2
    glob tf*
} {tf2}
test fCmd-6.10 {CopyRenameOneFile: lstat(target) == 0} {
    cleanup
    createfile tf1
    createfile tf2
    list [catch {file rename tf1 tf2} msg] $msg
} {1 {error renaming "tf1" to "tf2": file already exists}}
test fCmd-6.11 {CopyRenameOneFile: force == 0} {
    cleanup
    createfile tf1
    createfile tf2
    list [catch {file rename tf1 tf2} msg] $msg
} {1 {error renaming "tf1" to "tf2": file already exists}}
test fCmd-6.12 {CopyRenameOneFile: force != 0} {
    cleanup
    createfile tf1
    createfile tf2
    file rename -force tf1 tf2
    glob tf*
} {tf2}
test fCmd-6.13 {CopyRenameOneFile: source is dir, target is file} {
    cleanup
    file mkdir td1
    file mkdir td2
    createfile [file join td2 td1]
    list [catch {file rename -force td1 td2} msg] $msg
} [subst {1 {can't overwrite file "[file join td2 td1]" with directory "td1"}}]
test fCmd-6.14 {CopyRenameOneFile: source is file, target is dir} {
    cleanup
    createfile tf1
    file mkdir [file join td1 tf1]
    list [catch {file rename -force tf1 td1} msg] $msg
} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}]
test fCmd-6.15 {CopyRenameOneFile: TclpRenameFile succeeds} {
    cleanup
    file mkdir [file join td1 td2]
    file mkdir td2
    createfile [file join td2 tf1]
    file rename -force td2 td1
    file exists [file join td1 td2 tf1]
} {1}
test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} {
    cleanup
    file mkdir [file join td1 td2]
    createfile [file join td1 td2 tf1]
    file mkdir td2
    list [catch {file rename -force td2 td1} msg] $msg
} [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}]
test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} {!$::test::testConfig(win32s) || ($root == "C:/")} {
    # Don't run this test under Win32s on a drive mounted from an NT 
    # machine; it causes the NT machine to die.


    cleanup
    list [catch {file rename -force $root tf1} msg] $msg
} [subst {1 {error renaming "$root" to "tf1": trying to rename a volume or move a directory into itself}}]
test fCmd-6.18 {CopyRenameOneFile: errno != EXDEV} {
    cleanup
    file mkdir [file join td1 td2]
    createfile [file join td1 td2 tf1]
    file mkdir td2
    list [catch {file rename -force td2 td1} msg] $msg
} [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}]
test fCmd-6.19 {CopyRenameOneFile: errno == EXDEV} {unixOnly} {
    cleanup /tmp
    createfile tf1
    file rename tf1 /tmp
    glob tf* /tmp/tf1
} {/tmp/tf1}
test fCmd-6.20 {CopyRenameOneFile: errno == EXDEV} {pcOnly} {
    catch {file delete -force c:/[email protected] d:/[email protected]}
................................................................................
	list d:/[email protected]
    } else {
	set msg [glob c:/[email protected] d:/[email protected]]
	file delete -force d:/[email protected]
	set msg
    }
} {d:/[email protected]}
test fCmd-6.21 {CopyRenameOneFile: copy/rename: S_ISDIR(source)} {unixOnly} {

    cleanup /tmp
    file mkdir td1
    file rename td1 /tmp
    glob td* /tmp/td*
} {/tmp/td1}
test fCmd-6.22 {CopyRenameOneFile: copy/rename: !S_ISDIR(source)} {unixOnly} {

    cleanup /tmp
    createfile tf1
    file rename tf1 /tmp
    glob tf* /tmp/tf*
} {/tmp/tf1}
test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} {unixOnly xdev} {

    cleanup /tmp
    file mkdir td1/td2/td3
    exec chmod 000 td1
    set msg [list [catch {file rename td1 /tmp} msg] $msg]
    exec chmod 755 td1
    set msg 
} {1 {error renaming "td1": permission denied}}
test fCmd-6.24 {CopyRenameOneFile: error uses original name} {unixOnly} {

    cleanup
    file mkdir ~/td1/td2
    exec chmod 000 [file join [file dirname ~] [file tail ~] td1]
    set msg [list [catch {file copy ~/td1 td1} msg] $msg]
    exec chmod 755 [file join [file dirname ~] [file tail ~] td1]
    file delete -force ~/td1
    set msg
} {1 {error copying "~/td1": permission denied}}
test fCmd-6.25 {CopyRenameOneFile: error uses original name} {unixOnly} {

    cleanup
    file mkdir td2
    file mkdir ~/td1
    exec chmod 000 [file join [file dirname ~] [file tail ~] td1]
    set msg [list [catch {file copy td2 ~/td1} msg] $msg]
    exec chmod 755 [file join [file dirname ~] [file tail ~] td1]
    file delete -force ~/td1
    set msg
} {1 {error copying "td2" to "~/td1/td2": permission denied}}
test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} {unixOnly} {

    cleanup
    file mkdir ~/td1/td2
    exec chmod 000 [file join [file dirname ~] [file tail ~] td1 td2]
    set msg [list [catch {file copy ~/td1 td1} msg] $msg]
    exec chmod 755 [file join [file dirname ~] [file tail ~] td1 td2]
    file delete -force ~/td1
    set msg
} "1 {error copying \"~/td1\" to \"td1\": \"[file join [file dirname ~] [file tail ~] td1 td2]\": permission denied}"
test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} {unixOnly xdev} {

    cleanup /tmp
    file mkdir td1/td2/td3
    file mkdir /tmp/td1
    createfile /tmp/td1/tf1
    list [catch {file rename -force td1 /tmp} msg] $msg
} {1 {error renaming "td1" to "/tmp/td1": file already exists}}
test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} {unixOnly xdev} {

    cleanup /tmp
    file mkdir td1/td2/td3
    exec chmod 000 td1/td2/td3 
    set msg [list [catch {file rename td1 /tmp} msg] $msg]
    exec chmod 755 td1/td2/td3 
    set msg
} {1 {error renaming "td1" to "/tmp/td1": "td1/td2/td3": permission denied}}
test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} {unixOnly xdev} {

    cleanup /tmp
    file mkdir td1/td2/td3
    file rename td1 /tmp
    glob td* /tmp/td1/t*
} {/tmp/td1/td2}
test fCmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} {unixOnly} {

    cleanup
    file mkdir foo/bar
    file attr foo -perm 040555
    set msg [list [catch {file rename foo/bar /tmp} msg] $msg]
    catch {file delete /tmp/bar}
    catch {file attr foo -perm 040777}
    catch {file delete -force foo}
    set msg
} {1 {can't unlink "foo/bar": permission denied}}
test fCmd-6.31 {CopyRenameOneFile: TclpDeleteFile passed} {unixOnly xdev} {

    catch {cleanup /tmp}
    file mkdir /tmp/td1
    createfile /tmp/td1/tf1
    file rename /tmp/td1/tf1 tf1
    list [file exists /tmp/td1/tf1] [file exists tf1]
} {0 1}
test fCmd-6.32 {CopyRenameOneFile: copy} {
    cleanup
    list [catch {file copy tf1 tf2} msg] $msg
} {1 {error copying "tf1": no such file or directory}}
catch {cleanup /tmp}

test fCmd-7.1 {FileForceOption: none} {
    cleanup
    file mkdir [file join tf1 tf2]
    list [catch {file delete tf1} msg] $msg
} {1 {error deleting "tf1": directory not empty}}
test fCmd-7.2 {FileForceOption: -force} {
    cleanup
    file mkdir [file join tf1 tf2]
    file delete -force tf1
} {}
test fCmd-7.3 {FileForceOption: --} {
    createfile -tf1
    file delete -- -tf1
} {}
test fCmd-7.4 {FileForceOption: bad option} {
    createfile -tf1
    set msg [list [catch {file delete -tf1} msg] $msg]
    file delete -- -tf1
    set msg
} {1 {bad option "-tf1": should be -force or --}}
test fCmd-7.5 {FileForceOption: multiple times through loop} {
    createfile --
    createfile -force
    file delete -force -force -- -- -force
    list [catch {glob -- -- -force} msg] $msg
} {1 {no files matched glob patterns "-- -force"}}

test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} {unixOnly} {

    file mkdir td1
    file attr td1 -perm 040000
    set result [list [catch {file rename ~$user td1} msg] $msg]
    file delete -force td1
    set result
} "1 {error renaming \"~$user\" to \"td1/[file tail ~$user]\": permission denied}"

test fCmd-9.1 {file rename: comprehensive: EACCES} {unixOnly} {
    cleanup
    file mkdir td1
    file mkdir td2
    file attr td2 -perm 040000
    set result [list [catch {file rename td1 td2/} msg] $msg]
    file delete -force td2
    file delete -force td1
    set result
} {1 {error renaming "td1" to "td2/td1": permission denied}}
test fCmd-9.2 {file rename: comprehensive: source doesn't exist} {
    cleanup
    list [catch {file rename tf1 tf2} msg] $msg
} {1 {error renaming "tf1": no such file or directory}}
test fCmd-9.3 {file rename: comprehensive: file to new name} {
    cleanup
    createfile tf1
    createfile tf2
    testchmod 444 tf2
    file rename tf1 tf3
    file rename tf2 tf4
    list [lsort [glob tf*]] [file writable tf3] [file writable tf4]
} {{tf3 tf4} 1 0}    
test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc} {
    cleanup
    file mkdir td1 td2
    testchmod 555 td2
    file rename td1 td3
    file rename td2 td4
    list [lsort [glob td*]] [file writable td3] [file writable td4]
} {{td3 td4} 1 0}    
test fCmd-9.5 {file rename: comprehensive: file to self} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    testchmod 444 tf2
    file rename -force tf1 tf1
    file rename -force tf2 tf2
    list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2]
} {tf1 tf2 1 0}    
test fCmd-9.6 {file rename: comprehensive: dir to self} {unixOrPc} {
    cleanup
    file mkdir td1
    file mkdir td2
    testchmod 555 td2
    file rename -force td1 .
    file rename -force td2 .
    list [lsort [glob td*]] [file writable td1] [file writable td2]
} {{td1 td2} 1 0}    
test fCmd-9.7 {file rename: comprehensive: file to existing file} {
    cleanup
    createfile tf1
    createfile tf2
    createfile tfs1
    createfile tfs2
    createfile tfs3
    createfile tfs4
................................................................................
    set msg [list [catch {file rename tf1 tf2} msg] $msg]
    file rename -force tfs1 tfd1
    file rename -force tfs2 tfd2
    file rename -force tfs3 tfd3
    file rename -force tfs4 tfd4
    list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] 
} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0}
test fCmd-9.8 {file rename: comprehensive: dir to empty dir} {
    # Under unix, you can rename a read-only directory, but you can't
    # move it into another directory.

    cleanup
    file mkdir td1
    file mkdir [file join td2 td1]
    file mkdir tds1
................................................................................
    } else {
	set w3 0
	set w4 0
    }
    list [lsort [glob td*]] $msg [file writable [file join tdd1 tds1]] \
    [file writable [file join tdd2 tds2]] $w3 $w4
} [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4} {1 {error renaming "td1" to "[file join td2 td1]": file already exists}} 1 1 0 0}]
test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} {
    cleanup
    file mkdir tds1
    file mkdir tds2
    file mkdir [file join tdd1 tds1 xxx]
    file mkdir [file join tdd2 tds2 xxx]
    if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} {
	testchmod 555 tds2
................................................................................
    if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} {
	set w2 [file writable tds2]
    } else {
	set w2 0
    }
    list [lsort [glob td*]] $a1 $a2 [file writable tds1] $w2
} [subst {{tdd1 tdd2 tds1 tds2} {1 {error renaming "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error renaming "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}]
test fCmd-9.10 {file rename: comprehensive: file to new name and dir} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    testchmod 444 tf2
    file rename tf1 [file join td1 tf3]
    file rename tf2 [file join td1 tf4]
    list [catch {glob tf*}] [lsort [glob [file join td1 t*]]] \
    [file writable [file join td1 tf3]] [file writable [file join td1 tf4]]
} [subst {1 {[file join td1 tf3] [file join td1 tf4]} 1 0}]
test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} {
    cleanup
    file mkdir td1
    file mkdir td2
    file mkdir td3
    if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} {
	testchmod 555 td2
    }
................................................................................
	set w4 [file writable [file join td3 td4]]
    } else {
        set w4 0
    }
    list [lsort [glob td*]] [lsort [glob [file join td3 t*]]] \
    [file writable [file join td3 td3]] $w4
} [subst {td3 {[file join td3 td3] [file join td3 td4]} 1 0}]
test fCmd-9.12 {file rename: comprehensive: target exists} {
    cleanup
    file mkdir [file join td1 td2] [file join td2 td1]
    if {$tcl_platform(platform) != "macintosh"} {
    	testchmod 555 [file join td2 td1]
    }
    file mkdir [file join td3 td4] [file join td4 td3]
    file rename -force td3 td4
................................................................................
    set msg [list [file exists td3] [file exists [file join td4 td3 td4]] \
    [catch {file rename td1 td2} msg] $msg]
    if {$tcl_platform(platform) != "macintosh"} {
    	testchmod 755 [file join td2 td1]
    }
    set msg
} [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}]
test fCmd-9.13 {file rename: comprehensive: can't overwrite target} {
    cleanup
    file mkdir [file join td1 td2] [file join td2 td1 td4]
    list [catch {file rename -force td1 td2} msg] $msg
} [subst {1 {error renaming "td1" to "[file join td2 td1]": file already exists}}]
test fCmd-9.14 {file rename: comprehensive: dir into self} {
    cleanup
    file mkdir td1
    list [glob td*] [list [catch {file rename td1 td1} msg] $msg]
} [subst {td1 {1 {error renaming "td1" to "[file join td1 td1]": trying to rename a volume or move a directory into itself}}}]
test fCmd-9.15 {file rename: comprehensive: source and target incompatible} {

    cleanup
    file mkdir td1
    createfile tf1
    list [catch {file rename -force td1 tf1} msg] $msg
} {1 {can't overwrite file "tf1" with directory "td1"}}
test fCmd-9.16 {file rename: comprehensive: source and target incompatible} {

    cleanup
    file mkdir td1/tf1
    createfile tf1
    list [catch {file rename -force tf1 td1} msg] $msg
} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}]

test fCmd-10.1 {file copy: comprehensive: source doesn't exist} {
    cleanup
    list [catch {file copy tf1 tf2} msg] $msg
} {1 {error copying "tf1": no such file or directory}}
test fCmd-10.2 {file copy: comprehensive: file to new name} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    testchmod 444 tf2
    file copy tf1 tf3
    file copy tf2 tf4
    list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4]
} {{tf1 tf2 tf3 tf4} tf1 tf2 1 0}
test fCmd-10.3 {file copy: comprehensive: dir to new name} {unixOrPc} {
    cleanup
    file mkdir [file join td1 tdx]
    file mkdir [file join td2 tdy]
    testchmod 555 td2
    file copy td1 td3
    file copy td2 td4
    set msg [list [lsort [glob td*]] [glob [file join td3 t*]] \
................................................................................
	    [glob [file join td4 t*]] [file writable td3] [file writable td4]]
    if {$tcl_platform(platform) != "macintosh"} {
    	testchmod 755 td2
    	testchmod 755 td4
    }
    set msg
} [subst {{td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0}]
test fCmd-10.4 {file copy: comprehensive: file to existing file} {
    cleanup
    createfile tf1
    createfile tf2
    createfile tfs1
    createfile tfs2
    createfile tfs3
    createfile tfs4
................................................................................
    set msg [list [catch {file copy tf1 tf2} msg] $msg]
    file copy -force tfs1 tfd1
    file copy -force tfs2 tfd2
    file copy -force tfs3 tfd3
    file copy -force tfs4 tfd4
    list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] 
} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4 tfs1 tfs2 tfs3 tfs4} {1 {error copying "tf1" to "tf2": file already exists}} 1 1 0 0}
test fCmd-10.5 {file copy: comprehensive: dir to empty dir} {
    cleanup
    file mkdir td1
    file mkdir [file join td2 td1]
    file mkdir tds1
    file mkdir tds2
    file mkdir tds3
    file mkdir tds4
................................................................................
    set a1 [list [catch {file copy td1 td2} msg] $msg]
    set a2 [list [catch {file copy -force tds1 tdd1} msg] $msg]
    set a3 [catch {file copy -force tds2 tdd2}]
    set a4 [catch {file copy -force tds3 tdd3}]
    set a5 [catch {file copy -force tds4 tdd4}]
    list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5 
} [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}]
test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} {unixOrPc} {

    cleanup
    file mkdir tds1
    file mkdir tds2
    file mkdir [file join tdd1 tds1 xxx]
    file mkdir [file join tdd2 tds2 xxx]
    testchmod 555 tds2
    set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg]
    set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg]
    list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2]
} [subst {{tdd1 tdd2 tds1 tds2} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error copying "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}]
test fCmd-10.7 {file rename: comprehensive: file to new name and dir} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    testchmod 444 tf2
    file copy tf1 [file join td1 tf3]
    file copy tf2 [file join td1 tf4]
    list [lsort [glob tf*]] [lsort [glob [file join td1 t*]]] \
    [file writable [file join td1 tf3]] [file writable [file join td1 tf4]]
} [subst {{tf1 tf2} {[file join td1 tf3] [file join td1 tf4]} 1 0}]
test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} {unixOrPc} {

    cleanup
    file mkdir td1
    file mkdir td2
    file mkdir td3
    testchmod 555 td2
    file copy td1 [file join td3 td3]
    file copy td2 [file join td3 td4]
    list [lsort [glob td*]] [lsort [glob [file join td3 t*]]] \
    [file writable [file join td3 td3]] [file writable [file join td3 td4]]
} [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 0}]
test fCmd-10.9 {file copy: comprehensive: source and target incompatible} {

    cleanup
    file mkdir td1
    createfile tf1
    list [catch {file copy -force td1 tf1} msg] $msg
} {1 {can't overwrite file "tf1" with directory "td1"}}
test fCmd-10.10 {file copy: comprehensive: source and target incompatible} {

    cleanup
    file mkdir [file join td1 tf1]
    createfile tf1
    list [catch {file copy -force tf1 td1} msg] $msg
} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}]
cleanup    

# old tests    

test fCmd-11.1 {TclFileRenameCmd: -- option } {
    catch {file delete -force -- -tfa1}
    set s [createfile -tfa1]
    file rename -- -tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] && ![file exists -tfa1]]
    file delete tfa2
    set result
} {1}

test fCmd-11.2 {TclFileRenameCmd: bad option } {
    catch {file delete -force -- tfa1}
    set s [createfile tfa1]
    set r1 [catch {file rename -x tfa1 tfa2}]
    set result [expr $r1 && [checkcontent tfa1 $s] && ![file exists tfa2]]
    file delete tfa1
    set result
} {1}

test fCmd-11.3 {TclFileRenameCmd: bad \# args} {
    catch {file rename -- }
} {1}

test fCmd-11.4 {TclFileRenameCmd: target filename translation failing} {
     global env
     set temp $env(HOME)
     unset env(HOME)
     set result [catch {file rename tfa ~/foobar }]
     set env(HOME) $temp
     set result
 } {1}

test fCmd-11.5 {TclFileRenameCmd: more than one source and target is not a directory} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
    createfile tfa1 
    createfile tfa2 
    createfile tfa3 
    set result [catch {file rename tfa1 tfa2 tfa3}]
    file delete tfa1 tfa2 tfa3
    set result
} {1}

test fCmd-11.6 {TclFileRenameCmd: : single file into directory  } {
    catch {file delete -force -- tfa1 tfad}
    set s [createfile tfa1]
    file mkdir tfad
    file rename tfa1 tfad
    set result [expr [checkcontent tfad/tfa1 $s] && ![file exists tfa1]]
    file delete -force tfad
    set result
} {1}

test fCmd-11.7 {TclFileRenameCmd: : multiple files into directory  } {
    catch {file delete -force -- tfa1 tfa2 tfad}
    set s1 [createfile tfa1 ]
    set s2 [createfile tfa2 ]
    file mkdir tfad
    file rename tfa1 tfa2 tfad
    set r1 [checkcontent tfad/tfa1 $s1]
    set r2 [checkcontent tfad/tfa2 $s2]
................................................................................
    
    set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfa2]]
	    
    file delete -force tfad
    set result
} {1}

test fCmd-11.8 {TclFileRenameCmd: error renaming file to directory } {
    catch {file delete -force -- tfa tfad}
    set s [createfile tfa ]
    file mkdir tfad
    file mkdir tfad/tfa
    set r1 [catch {file rename tfa tfad}]
    set r2 [checkcontent tfa $s]
    set r3 [file isdir tfad]
................................................................................
    file delete -force tfa tfad
    set result
} {1}

#
# Coverage tests for renamefile() ;
#
test fCmd-12.1 {renamefile: source filename translation failing} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set result [catch {file rename ~/tfa1 tfa2}]
    set env(HOME) $temp
    set result
} {1}

test fCmd-12.2 {renamefile: src filename translation failing} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set s [createfile tfa1]
    file mkdir tfad
    set result [catch {file rename tfa1 ~/tfa2 tfad}]
    set env(HOME) $temp
    file delete -force tfad
    set result
} {1}

test fCmd-12.3 {renamefile: stat failing on source} {
    catch {file delete -force -- tfa1 tfa2}
    set r1 [catch {file rename tfa1 tfa2}]
    expr {$r1 && ![file exists tfa1] && ![file exists tfa2]}
} {1}

test fCmd-12.4 {renamefile: error renaming file to directory } {
    catch {file delete -force -- tfa tfad}
    set s1 [createfile tfa ]
    file mkdir tfad
    file mkdir tfad/tfa
    set r1 [catch {file rename tfa tfad}]
    set r2 [checkcontent tfa $s1]
    set r3 [file isdir tfad/tfa]
    set result [expr $r1 && $r2 && $r3]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-12.5 {renamefile: error renaming directory to file } {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa
    file mkdir tfad
    set s [createfile tfad/tfa]
    set r1 [catch {file rename tfa tfad}]
    set r2 [checkcontent tfad/tfa $s]
    set r3 [file isdir tfad]
    set r4 [file isdir tfa]
    set result [expr $r1 && $r2 && $r3 && $r4 ]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-12.6 {renamefile: TclRenameFile succeeding } {
    catch {file delete -force -- tfa1 tfa2}
    set s [createfile tfa1]
    file rename tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] && ![file exists tfa1]]
    file delete tfa2
    set result
} {1}

test fCmd-12.7 {renamefile: renaming directory into offspring} {
    catch {file delete -force -- tfad}
    file mkdir tfad
    file mkdir tfad/dir
    set result [catch {file rename tfad tfad/dir}]
    file delete -force tfad 
    set result
} {1}

test fCmd-12.8 {renamefile: generic error } {unixOnly} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/dir
    exec chmod 555 tfa
    set result [catch {file rename tfa/dir tfa2}]
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}


test fCmd-12.9 {renamefile: moving a file across volumes } {unixOnly} {
    catch {file delete -force -- tfa /tmp/tfa}
    set s [createfile tfa ]
    file rename tfa /tmp
    set result [expr [checkcontent /tmp/tfa $s] && ![file exists tfa]]
    file delete /tmp/tfa
    set result
} {1}

test fCmd-12.10 {renamefile: moving a directory across volumes } {unixOnly} {

    catch {file delete -force -- tfad /tmp/tfad}
    file mkdir tfad
    set s [createfile tfad/a ]
    file rename tfad /tmp
    set restul [expr [checkcontent /tmp/tfad/a $s] && ![file exists tfad]]
    file delete -force /tmp/tfad
    set result
} {1}

#
# Coverage tests for TclCopyFilesCmd()
#
test fCmd-13.1 {TclCopyFilesCmd: -force option } {
    catch {file delete -force -- tfa1}
    set s [createfile tfa1]
    file copy -force  tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] && [checkcontent tfa1 $s]]
    file delete tfa1 tfa2
    set result
} {1}

test fCmd-13.2 {TclCopyFilesCmd: -- option } {
    catch {file delete -force -- tfa1}
    set s [createfile -tfa1]
    file copy --  -tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] &&  [checkcontent -tfa1 $s]]
    file delete -- -tfa1 tfa2
    set result
} {1}

test fCmd-13.3 {TclCopyFilesCmd: bad option } {
    catch {file delete -force -- tfa1}
    set s [createfile tfa1]
    set r1 [catch {file copy -x tfa1 tfa2}]
    set result [expr $r1 && [checkcontent tfa1 $s] && ![file exists tfa2]]
    file delete tfa1
    set result
} {1}

test fCmd-13.4 {TclCopyFilesCmd: bad \# args} {
    catch {file copy -- }
} {1}

test fCmd-13.5 {TclCopyFilesCmd: target filename translation failing} {
     global env
     set temp $env(HOME)
    unset env(HOME)
     set result [catch {file copy tfa ~/foobar }]
     set env(HOME) $temp
     set result
 } {1}

test fCmd-13.6 {TclCopyFilesCmd: more than one source and target is not a directory} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
    createfile tfa1 
    createfile tfa2 
    createfile tfa3 
    set result [catch {file copy tfa1 tfa2 tfa3}]
    file delete tfa1 tfa2 tfa3
    set result
} {1}

test fCmd-13.7 {TclCopyFilesCmd: : single file into directory  } {
    catch {file delete -force -- tfa1 tfad}
    set s [createfile tfa1]
    file mkdir tfad
    file copy tfa1 tfad
    set result [expr [checkcontent tfad/tfa1 $s] &&  [checkcontent tfa1 $s]]
    file delete -force tfad tfa1
    set result
} {1}

test fCmd-13.8 {TclCopyFilesCmd: : multiple files into directory  } {
    catch {file delete -force -- tfa1 tfa2 tfad}
    set s1 [createfile tfa1 ]
    set s2 [createfile tfa2 ]
    file mkdir tfad
    file copy tfa1 tfa2 tfad
    set r1 [checkcontent tfad/tfa1 $s1]
    set r2 [checkcontent tfad/tfa2 $s2]
................................................................................
    set r4 [checkcontent tfa2 $s2]
    set result [expr $r1 && $r2 && $r3 && $r4 ]
	    
    file delete -force tfad tfa1 tfa2
    set result
} {1}

test fCmd-13.9 {TclCopyFilesCmd: error copying file to directory } {
    catch {file delete -force -- tfa tfad}
    set s [createfile tfa ]
    file mkdir tfad
    file mkdir tfad/tfa
    set r1 [catch {file copy tfa tfad}]
    set r2 [expr [checkcontent tfa $s] && [file isdir tfad/tfa]]
    set r3 [file isdir tfad]
................................................................................
    file delete -force tfa tfad
    set result
} {1}

#
# Coverage tests for copyfile()
# 
test fCmd-14.1 {copyfile: source filename translation failing} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set result [catch {file copy ~/tfa1 tfa2}]
    set env(HOME) $temp
    set result
} {1}

test fCmd-14.2 {copyfile: dst filename translation failing} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set s [createfile tfa1]
    file mkdir tfad
    set r1 [catch {file copy tfa1 ~/tfa2 tfad}]
    set result [expr $r1 && [checkcontent tfad/tfa1 $s]]
    set env(HOME) $temp
    file delete -force tfa1 tfad
    set result
} {1}

test fCmd-14.3 {copyfile: stat failing on source} {
    catch {file delete -force -- tfa1 tfa2}
    set r1 [catch {file copy tfa1 tfa2}]
    expr $r1 && ![file exists tfa1] && ![file exists tfa2]
} {1}

test fCmd-14.4 {copyfile: error copying file to directory } {
    catch {file delete -force -- tfa tfad}
    set s1 [createfile tfa ]
    file mkdir tfad
    file mkdir tfad/tfa
    set r1 [catch {file copy tfa tfad}]
    set r2 [checkcontent tfa $s1]
    set r3 [file isdir tfad]
    set r4 [file isdir tfad/tfa]
    set result [expr $r1 && $r2 && $r3 && $r4 ]
    file delete -force tfa tfad
    set result
} {1}

 test fCmd-14.5 {copyfile: error copying directory to file } {
     catch {file delete -force -- tfa tfad}
     file mkdir tfa
     file mkdir tfad
     set s [createfile tfad/tfa]
     set r1 [catch {file copy tfa tfad}]
     set r2 [checkcontent tfad/tfa $s]
     set r3 [file isdir tfad]
     set r4 [file isdir tfa]
     set result [expr $r1 && $r2 && $r3 && $r4 ]
     file delete -force tfa tfad
     set result
} {1}

test fCmd-14.6 {copyfile: copy file succeeding } {
    catch {file delete -force -- tfa tfa2}
    set s [createfile tfa]
    file copy tfa tfa2
    set result [expr  [checkcontent tfa $s] && [checkcontent tfa2 $s]]
    file delete tfa tfa2
    set result
} {1}

test fCmd-14.7 {copyfile: copy directory succeeding } {
    catch {file delete -force -- tfa tfa2}
    file mkdir tfa
    set s [createfile tfa/file]
    file copy tfa tfa2
    set result [expr [checkcontent tfa/file $s] && [checkcontent tfa2/file $s]]
    file delete -force tfa tfa2
    set result
} {1}

test fCmd-14.8 {copyfile: copy directory failing } {unixOnly} {
    catch {file delete -force -- tfa}
    file mkdir tfa/dir/a/b/c
    exec chmod 000 tfa/dir
    set r1 [catch {file copy tfa tfa2}]
    exec chmod 777 tfa/dir
    set result $r1
    file delete -force tfa tfa2
    set result
} {1}

#
# Coverage tests for TclMkdirCmd()
#
test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} {
    global env
    set temp $env(HOME)
    unset env(HOME) 
    set result [catch {file mkdir ~/tfa}]
    set env(HOME) $temp
    set result
} {1}
#
# Can Tcl_SplitPath return argc == 0? If so them we need a
# test for that code.
#
test fCmd-15.2 {TclMakeDirsCmd - one directory } {
    catch {file delete -force -- tfa}
    file mkdir tfa
    set result [file isdirectory tfa]
    file delete tfa
    set result
} {1}

test fCmd-15.3 {TclMakeDirsCmd: - two directories } {
    catch {file delete -force -- tfa1 tfa2}
    file mkdir tfa1 tfa2
    set result [expr [file isdirectory tfa1] && [file isdirectory tfa2]]
    file delete tfa1 tfa2
    set result
} {1}

test fCmd-15.4 {TclMakeDirsCmd - stat failing } {unixOnly} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/file
    exec chmod 000 tfa
    set result [catch {file mkdir tfa/file}]
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}

test fCmd-15.5 {TclMakeDirsCmd: - making a directory several levels deep } {

    catch {file delete -force -- tfa}
    file mkdir tfa/a/b/c
    set result [file isdir tfa/a/b/c]
    file delete -force tfa
    set result
} {1}

    
test fCmd-15.6 {TclMakeDirsCmd: - trying to overwrite a file } {
    catch {file delete -force -- tfa}
    set s [createfile tfa]
    set r1 [catch {file mkdir tfa}]
    set r2 [file isdir tfa]
    set r3 [file exists tfa]
    set result [expr $r1 && !$r2 && $r3 && [checkcontent tfa $s]]
    file delete tfa
    set result
} {1}

test fCmd-15.7 {TclMakeDirsCmd - making several directories } {
    catch {file delete -force -- tfa1 tfa2}
    file mkdir tfa1 tfa2/a/b/c
    set result [expr [file isdir tfa1] && [file isdir tfa2/a/b/c]]
    file delete -force tfa1 tfa2
    set result
} {1}

test fCmd-15.8 {TclFileMakeDirsCmd: trying to create an existing dir} {
    file mkdir tfa
    file mkdir tfa
    set result [file isdir tfa]
    file delete tfa
    set result
} {1}


# Coverage tests for TclDeleteFilesCommand()
test fCmd-16.1 { test the -- argument } {
    catch {file delete -force -- tfa}
    createfile tfa
    file delete -- tfa
    file exists tfa
} {0}

test fCmd-16.2 { test the -force and -- arguments } {
    catch {file delete -force -- tfa}
    createfile tfa
    file delete -force -- tfa
    file exists tfa
} {0}

test fCmd-16.3 { test bad option } {
    catch {file delete -force -- tfa}
    createfile tfa
    set result [catch {file delete -dog tfa}]
    file delete tfa
    set result
} {1}

test fCmd-16.4 { test not enough args } {
    catch {file delete}
} {1}

test fCmd-16.5 { test not enough args with options } {
    catch {file delete --}
} {1}

test fCmd-16.6 {delete: source filename translation failing} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set result [catch {file delete ~/tfa}]
    set env(HOME) $temp
    set result
} {1}

test fCmd-16.7 {remove a non-empty directory without -force } {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/a
    set result [catch  {file delete tfa }]
    file delete -force tfa
    set result
} {1}

test fCmd-16.8 {remove a normal file } {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/a
    set result [catch  {file delete tfa }]
    file delete -force tfa
    set result
} {1}

test fCmd-16.9 {error while deleting file } {unixOnly} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/a
    exec chmod 555 tfa
    set result [catch  {file delete tfa/a }]
    #######
    #######  If any directory in a tree that is being removed does not 
................................................................................
    #######  This is also the case with "rm -rf"
    #######
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}

test fCmd-16.10 {deleting multiple files } {
    catch {file delete -force -- tfa1 tfa2}
    createfile tfa1
    createfile tfa2
    file delete tfa1 tfa2
    expr ![file exists tfa1] && ![file exists tfa2]
} {1}

test fCmd-16.11 { TclFileDeleteCmd: removing a nonexistant file} {
    catch {file delete -force -- tfa}
    file delete tfa
    set result 1
} {1}

# More coverage tests for mkpath()
 test fCmd-17.1 {mkdir stat failing on target but not ENOENT } {unixOnly} {
     catch {file delete -force -- tfa1}
     file mkdir tfa1
     exec chmod 555 tfa1
     set result [catch {file mkdir tfa1/tfa2}]
     exec chmod 777 tfa1
     file delete -force tfa1
     set result
} {1}

test fCmd-17.2 {mkdir several levels deep - relative } {
    catch {file delete -force -- tfa}
    file mkdir tfa/a/b
    set result [file isdir tfa/a/b ]
    file delete tfa/a/b tfa/a tfa
    set result
} {1}

test fCmd-17.3 {mkdir several levels deep - absolute } {
    catch {file delete -force -- tfa}
    set f [file join [pwd] tfa a ]
    file mkdir $f
    set result [file isdir $f ]
    file delete $f [file join [pwd] tfa]
    set result
} {1}

#
# Functionality tests for TclFileRenameCmd()
#

test fCmd-18.1 {TclFileRenameCmd: rename (first form) in the same directory} {

    catch {file delete -force -- tfad}
    file mkdir tfad/dir
    cd tfad/dir
    set s [createfile foo ]
    file rename  foo bar
    file rename bar ./foo
    file rename ./foo bar
................................................................................
    file rename foo [file join [pwd] bar]
    set result [expr [checkcontent bar $s] && ![file exists foo]]
    cd ../..
    file delete -force tfad
    set result
} {1}

test fCmd-18.2 {TclFileRenameCmd: single dir to nonexistant } {
    catch {file delete -force -- tfa1 tfa2}
    file mkdir tfa1
    file rename tfa1 tfa2
    set result [expr [file exists tfa2] && ![file exists tfa1]]
    file delete tfa2
    set result
} {1}

test fCmd-18.3 {TclFileRenameCmd: mixed dirs and files into directory  } {
    catch {file delete -force -- tfa1 tfad1 tfad2}
    set s [createfile tfa1 ]
    file mkdir tfad1 tfad2
    file rename tfa1 tfad1 tfad2
    set r1 [checkcontent  tfad2/tfa1 $s]
    set r2 [file isdir tfad2/tfad1]
    set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfad1]]
    file delete tfad2/tfa1
    file delete -force tfad2
    set result
} {1}

test fCmd-18.4 {TclFileRenameCmd: attempt to replace non-dir with dir } {
    catch {file delete -force -- tfa tfad}
    set s [createfile tfa ]
    file mkdir tfad
    set r1 [catch {file rename tfad tfa}]
    set r2 [checkcontent tfa $s]
    set r3 [file isdir tfad]
    set result [expr $r1 && $r2 && $r3 ]
    file delete tfa tfad
    set result
} {1}

test fCmd-18.5 {TclFileRenameCmd: attempt to replace dir with non-dir } {
    catch {file delete -force -- tfa tfad}
    set s [createfile tfa ]
    file mkdir tfad/tfa
    set r1 [catch {file rename tfa tfad}]
    set r2 [checkcontent tfa $s]
    set r3 [file isdir tfad/tfa]
    set result [expr $r1 && $r2 && $r3 ]
................................................................................
    file delete -force  tfa tfad
    set result
} {1}

#
# On Windows there is no easy way to determine if two files are the same
#
test fCmd-18.6 {TclFileRenameCmd: rename a file to itself} {macOrUnix}  {
    catch {file delete -force -- tfa}
    set s [createfile tfa]
    set r1 [catch {file rename tfa tfa}]
    set result [expr $r1 && [checkcontent tfa $s]]
    file delete tfa
    set result
} {1}

test fCmd-18.7 {TclFileRenameCmd: rename dir on top of another empty dir w/o -force} {

    catch {file delete -force -- tfa tfad}
    file mkdir tfa tfad/tfa
    set r1 [catch {file rename tfa tfad}]
    set result [expr $r1 && [file isdir tfa]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-18.8 {TclFileRenameCmd: rename dir on top of another empty dir w/ -force} {

    catch {file delete -force -- tfa tfad}
    file mkdir tfa tfad/tfa
    file rename -force tfa tfad
    set result [expr ![file isdir tfa]]
    file delete -force tfad
    set result
} {1}

test fCmd-18.9 {TclFileRenameCmd: rename dir on top of a non-empty dir w/o -force} {

    catch {file delete -force -- tfa tfad}
    file mkdir tfa tfad/tfa/file
    set r1 [catch {file rename tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -force} {

    catch {file delete -force -- tfa tfad}
    file mkdir tfa tfad/tfa/file
    set r1 [catch {file rename -force tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-18.11 {TclFileRenameCmd: rename a non-existant file} {
    catch {file delete -force -- tfa1}
    set r1 [catch {file rename tfa1 tfa2}]
    set result [expr $r1 && ![file exists tfa1] && ![file exists tfa2]]
} {1}

test fCmd-18.12 {TclFileRenameCmd : rename a symbolic link to file} {unixOnly} {

    catch {file delete -force -- tfa1 tfa2 tfa3}
	
    set s [createfile tfa1]
    exec ln -s tfa1 tfa2
    file rename tfa2 tfa3
    set t [file type tfa3]
    set result [expr { $t == "link" }]
    file delete tfa1 tfa3
    set result
} {1}

test fCmd-18.13 {TclFileRenameCmd : rename a symbolic link to dir} {unixOnly} {

    catch {file delete -force -- tfa1 tfa2 tfa3}
	
    file mkdir tfa1
    exec ln -s tfa1 tfa2
    file rename tfa2 tfa3
    set t [file type tfa3]
    set result [expr { $t == "link" }]
    file delete tfa1 tfa3
    set result
} {1}

test fCmd-18.14 {TclFileRenameCmd : rename a path with sym link} {unixOnly} {

    catch {file delete -force -- tfa1 tfa2 tfa3}
	
    file mkdir tfa1/a/b/c/d
    file mkdir tfa2
    set f [file join [pwd] tfa1/a/b] 
    set f2 [file join [pwd] {tfa2/b alias}]
    exec ln -s $f $f2
................................................................................
    set r1 [file isdir tfa3]
    set r2 [file exists tfa1/a/b/c]
    set result [expr $r1 && !$r2]
    file delete -force tfa1 tfa2 tfa3
    set result
} {1}

test fCmd-18.15 {TclFileRenameCmd : rename a file to a symlink dir} {unixOnly} {

    catch {file delete -force -- tfa1 tfa2 tfalink}
	
    file mkdir tfa1
    set s [createfile tfa2]
    exec ln -s tfa1 tfalink

    file rename tfa2 tfalink
    set result [checkcontent tfa1/tfa2 $s ]
    file delete -force tfa1 tfalink
    set result
} {1}

test fCmd-18.16 {TclFileRenameCmd : rename a dangling symlink} {unixOnly} {
    catch {file delete -force -- tfa1 tfalink}
	
    file mkdir tfa1
    exec ln -s tfa1 tfalink
    file delete tfa1 
    file rename tfalink tfa2
    set result [expr [string compare [file type tfa2] "link"] == 0]
................................................................................
    set result
} {1}


#
# Coverage tests for TclUnixRmdir
#
test fCmd-19.1 { remove empty directory } {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file delete tfa
    file exists tfa
} {0}

test fCmd-19.2 { rmdir error besides EEXIST} {unixOnly} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/a
    exec chmod 555 tfa
    set result [catch {file delete tfa/a}]
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}

test fCmd-19.3 { recursive remove } {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/a
    file delete -force tfa
    file exists tfa
} {0}

................................................................................
#
#

#
# Coverage tests for TraverseUnixTree(), called from TclDeleteFilesCmd
#

test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory } {unixOnly} {

    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/a
    exec chmod 000 tfa/a
    set result [catch {file delete -force tfa}]
    exec chmod 777 tfa/a
    file delete -force tfa
................................................................................
    set result
} {1}


#
# Feature testing for TclCopyFilesCmd
# 
test fCmd-21.1 {copy : single file to nonexistant } {
    catch {file delete -force -- tfa1 tfa2}
    set s [createfile tfa1]
    file copy tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] && [checkcontent tfa1 $s]]
    file delete tfa1 tfa2
    set result
} {1}

test fCmd-21.2 {copy : single dir to nonexistant } {
    catch {file delete -force -- tfa1 tfa2}
    file mkdir tfa1
    file copy tfa1 tfa2
    set result [expr [file isdir tfa2] && [file isdir tfa1]]
    file delete tfa1 tfa2
    set result
} {1}

test fCmd-21.3 {copy : single file into directory  } {
    catch {file delete -force -- tfa1 tfad}
    set s [createfile tfa1]
    file mkdir tfad
    file copy tfa1 tfad
    set result [expr [checkcontent tfad/tfa1 $s] && [checkcontent tfa1 $s]]
    file delete -force tfa1 tfad
    set result
} {1}

test fCmd-21.4 {copy : more than one source and target is not a directory} {

    catch {file delete -force -- tfa1 tfa2 tfa3}
    createfile tfa1 
    createfile tfa2 
    createfile tfa3 
    set result [catch {file copy tfa1 tfa2 tfa3}]
    file delete tfa1 tfa2 tfa3
    set result
} {1}

test fCmd-21.5 {copy : multiple files into directory  } {
    catch {file delete -force -- tfa1 tfa2 tfad}
    set s1 [createfile tfa1 ]
    set s2 [createfile tfa2 ]
    file mkdir tfad
    file copy tfa1 tfa2 tfad
    set r1 [checkcontent tfad/tfa1 $s1]
    set r2 [checkcontent tfad/tfa2 $s2]
................................................................................
    set r3 [checkcontent tfa1 $s1]
    set r4 [checkcontent tfa2 $s2]
    set result [expr $r1 && $r2 && $r3 && $r4]
    file delete -force tfa1 tfa2 tfad
    set result
} {1}

test fCmd-21.6 {copy : mixed dirs and files into directory  } {notFileSharing} {

    catch {file delete -force -- tfa1 tfad1 tfad2}
    set s [createfile tfa1 ]
    file mkdir tfad1 tfad2
    file copy tfa1 tfad1 tfad2
    set r1 [checkcontent [file join tfad2 tfa1] $s]
    set r2 [file isdir [file join tfad2 tfad1]]
    set r3 [checkcontent tfa1 $s]
    set result [expr $r1 && $r2 && $r3 && [file isdir tfad1]]
    file delete -force tfa1 tfad1 tfad2
    set result
} {1}

test fCmd-21.7 {TclCopyFilesCmd : copy a dangling link } {unixOnly} {
    file mkdir tfad1
    exec ln -s tfad1 tfalink
    file delete tfad1
    file copy tfalink tfalink2
    set result [string match [file type tfalink2] link]
    file delete tfalink tfalink2 
    set result
} {1}

test fCmd-21.8 {TclCopyFilesCmd : copy a link } {unixOnly} {
    file mkdir tfad1
    exec ln -s tfad1 tfalink
    file copy tfalink tfalink2
    set r1 [file type tfalink]
    set r2 [file type tfalink2]
    set r3 [file isdir tfad1]
    set result [expr {("$r1" == "link" ) && ("$r2" == "link" ) && $r3}]
    file delete tfad1 tfalink tfalink2
    set result
} {1}

test fCmd-21.9 {TclCopyFilesCmd : copy dir with a link in it } {unixOnly} {
    file mkdir tfad1
    exec ln -s "[pwd]/tfad1" tfad1/tfalink
    file copy tfad1 tfad2
    set result [string match [file type tfad2/tfalink] link]
    file delete -force tfad1 tfad2
    set result
} {1}

test fCmd-21.10 {TclFileCopyCmd: copy dir on top of another empty dir w/o -force} {

    catch {file delete -force -- tfa tfad}
    file mkdir tfa [file join tfad tfa]
    set r1 [catch {file copy tfa tfad}]
    set result [expr $r1 && [file isdir tfa]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-21.11 {TclFileCopyCmd: copy dir on top of a dir w/o -force} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa [file join tfad tfa file]
    set r1 [catch {file copy tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-21.12 {TclFileCopyCmd: copy dir on top of a non-empty dir w/ -force} {

    catch {file delete -force -- tfa tfad}
    file mkdir tfa [file join tfad tfa file]
    set r1 [catch {file copy -force tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]]
    file delete -force tfa tfad
    set result
} {1}
   
#
# Coverage testing for TclpRenameFile
#
test fCmd-22.1 { TclpRenameFile : rename and overwrite in a single dir } {
    catch {file delete -force -- tfa1 tfa2}
    set s [createfile tfa1]
    set s2 [createfile tfa2 q]
	
    set r1 [catch {rename tfa1 tfa2}]
    file rename -force tfa1 tfa2
    set result [expr $r1 && [checkcontent tfa2 $s]]
    file delete [glob tfa1 tfa2]
    set result
} {1}

test fCmd-22.2 { TclpRenameFile : attempt to overwrite itself } {macOrUnix} {
    catch {file delete -force -- tfa1}
    set s [createfile tfa1]	
    file rename -force tfa1 tfa1
    set result [checkcontent tfa1 $s]
    file delete tfa1 
    set result
} {1}

test fCmd-22.3 { TclpRenameFile : rename dir to existing dir } {
    catch {file delete -force -- d1 tfad}
    file mkdir d1 [file join tfad d1]
    set r1 [catch {file rename d1 tfad}]
    set result [expr $r1 && [file isdir d1] && [file isdir [file join tfad d1]]]
    file delete -force d1 tfad
    set result
} {1}

test fCmd-22.4 { TclpRenameFile : rename dir to dir several levels deep } {
    catch {file delete -force -- d1 tfad}
    file mkdir d1 [file join tfad a b c]
    file rename d1 [file join tfad a b c d1]
    set result [expr ![file isdir d1] && [file isdir [file join tfad a b c d1]]]
    file delete -force [glob d1 tfad]
    set result
} {1}


#
# TclMacCopyFile needs to be redone.
#
test fCmd-22.5 { TclMacCopyFile : copy and overwrite in a single dir } {
    catch {file delete -force -- tfa1 tfa2}
    set s [createfile tfa1]
    set s2 [createfile tfa2 q]

    set r1 [catch {file copy tfa1 tfa2}]
    file copy -force tfa1 tfa2
    set result [expr $r1 && [checkcontent tfa2 $s] && [checkcontent tfa1 $s]]
................................................................................
#

#
# TclMacRmdir
# Error cases are not covered.
#

test fCmd-23.1 { TclMacRmdir : trying to remove a nonempty directory } {
    catch {file delete -force -- tfad}
	
    file mkdir [file join tfad dir]
	
    set result [catch {file delete tfad}]
    file delete -force tfad 
    set result
} {1}

#
# TclMacDeleteFile	
# Error cases are not covered.
#
test fCmd-24.1 { TclMacDeleteFile : deleting a normal file } {
    catch {file delete -force -- tfa1}
	
    createfile tfa1
    file delete tfa1
    file exists tfa1
} {0}

#
# TclMacCopyDirectory
# Error cases are not covered.
#
test fCmd-25.1 { TclMacCopyDirectory : copying a normal directory} {notFileSharing} {

    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir [file join tfad1 a b c]
    file copy tfad1 tfad2
    set result [expr [file isdir [file join tfad1 a b c]] && [file isdir [file join tfad2 a b c]]]
    file delete -force tfad1 tfad2
    set result
} {1}

test fCmd-25.2 { TclMacCopyDirectory : copying a short path normal directory} {notFileSharing} {

    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    file copy tfad1 tfad2
    set result [expr [file isdir tfad1] && [file isdir tfad2]]
    file delete tfad1 tfad2
    set result
} {1}

test fCmd-25.3 { TclMacCopyDirectory : copying dirs between different dirs} {notFileSharing} {

    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir [file join tfad1 x y z]
    file mkdir [file join tfad2 dir]
    file copy tfad1 [file join tfad2 dir]
    set result [expr [file isdir [file join tfad1 x y z]] && [file isdir [file join tfad2 dir tfad1 x y z]]]
    file delete -force tfad1 tfad2
................................................................................
    set result
} {1}

#
# Functionality tests for TclDeleteFilesCmd
#

test fCmd-26.1 { TclDeleteFilesCmd : delete symlink} {unixOnly} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    exec ln -s tfad1 tfalink
    file delete tfalink

    set r1 [file isdir tfad1]
................................................................................
    set r2 [file exists tfalink]
    
    set result [expr $r1 && !$r2]
    file delete tfad1
    set result
} {1}

test fCmd-26.2 { TclDeleteFilesCmd : delete dir with symlink} {unixOnly} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    file mkdir tfad2
    exec ln -s tfad1 [file join tfad2 link]
    file delete -force tfad2

................................................................................
    set r2 [file exists tfad2]
    
    set result [expr $r1 && !$r2]
    file delete tfad1
    set result
} {1}

test fCmd-26.3 { TclDeleteFilesCmd : delete dangling symlink} {unixOnly} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    exec ln -s tfad1 tfad2
    file delete tfad1
    file delete tfad2

................................................................................
test fCmd-27.4 {TclFileAttrsCmd - getting one option} {
    catch {file delete -force -- foo.tmp}
    createfile foo.tmp
    set attrs [file attributes foo.tmp]
    list [catch {eval file attributes foo.tmp [lindex $attrs 0]}] [file delete -force -- foo.tmp]
} {0 {}}

set ::test::testConfig(tclGroup) 0
if {($tcl_platform(platform) == "macintosh") \
	|| ($tcl_platform(platform) == "windows")} {
    set ::test::testConfig(tclGroup) 1
} elseif {[catch {exec {groups}} groupList] == 0} {
    if {[lsearch $groupList tcl] != -1} {
	set ::test::testConfig(tclGroup) 1

    }


}

test fCmd-27.5 {TclFileAttrsCmd - setting one option} {tclGroup} {
    catch {file delete -force -- foo.tmp}
    createfile foo.tmp
    set attrs [file attributes foo.tmp]
    list [catch {eval file attributes foo.tmp [lrange $attrs 0 1]} msg] $msg [file delete -force -- foo.tmp]
} {0 {} {}}
test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} {tclGroup} {
    catch {file delete -force -- foo.tmp}
    createfile foo.tmp
    set attrs [file attributes foo.tmp]
    list [catch {eval file attributes foo.tmp [lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp]
} {0 {} {}}

# cleanup
cleanup
::test::cleanupTests
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
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
..
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
...
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
...
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
...
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
...
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
...
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
...
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
...
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
...
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
...
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
....
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
....
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
....
1255
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
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
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
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
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
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
....
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
....
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
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
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
1703
1704
1705
1706
1707
....
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
....
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
....
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
....
1791
1792
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
1838
1839
1840
1841
1842
1843
1844
....
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
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
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
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
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
....
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
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
....
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
....
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
# 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.
#
# RCS: @(#) $Id: fCmd.test,v 1.1.2.6 1999/03/23 20:06:22 hershey Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[string compare testgetplatform [info commands testgetplatform]] != 0} {
    puts "This application hasn't been compiled with the \"testgetplatform\""
    puts "command, therefore I am skipping all of these tests."
    return
}

set platform [testgetplatform]







if {"[info commands testchmod]" != "testchmod"} {
    puts "Skipping fCmd tests. This application does not seem to have the"
    puts "testchmod command that is needed to run these tests."
    return
}

# Several tests require need to match results against the unix username
set user {}
if {$tcl_platform(platform) == "unix"} {
    catch {set user [exec whoami]}
    if {$user == ""} {
	catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
    }
    if {$user == ""} {
	set user "root"
    }
}

proc createfile {file {string a}} {
    set f [open $file w]
    puts -nonewline $f $string
    close $f
    return $string
}
................................................................................
proc contents {file} {
    set f [open $file r]
    set r [read $f]
    close $f
    set r
}









set ::tcltest::testConfig(fileSharing) 0
set ::tcltest::testConfig(notFileSharing) 1

if {$tcl_platform(platform) == "macintosh"} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    if {[catch {file attributes foo.dir -readonly 1}] == 0} {
    	set ::tcltest::testConfig(fileSharing) 1
    	set ::tcltest::testConfig(notFileSharing) 0
    }
    file delete -force foo.dir
}

set ::tcltest::testConfig(xdev) 0

if {$tcl_platform(platform) == "unix"} {
    if {[catch {set m1 [exec df .]; set m2 [exec df /tmp]}] == 0} {
	set m1 [string range $m1 0 [expr [string first " " $m1]-1]]
	set m2 [string range $m2 0 [expr [string first " " $m2]-1]]
	if {$m1 != "" && $m2 != "" && $m1 != $m2 && [file exists $m1] && [file exists $m2]} {
	    set ::tcltest::testConfig(xdev) 1
	}
    }
}

set root [lindex [file split [pwd]] 0]

# A really long file name
................................................................................
set long "abcdefghihjllmnopqrstuvwxyz01234567890"
append long $long
append long $long
append long $long
append long $long
append long $long

test fCmd-1.1 {TclFileRenameCmd} {notRoot} {
    cleanup
    createfile tf1
    file rename tf1 tf2
    glob tf*
} {tf2}

test fCmd-2.1 {TclFileCopyCmd} {notRoot} {
    cleanup
    createfile tf1
    file copy tf1 tf2
    lsort [glob tf*]
} {tf1 tf2}

test fCmd-3.1 {FileCopyRename: FileForceOption fails} {notRoot} {
    list [catch {file rename -xyz} msg] $msg
} {1 {bad option "-xyz": should be -force or --}}
test fCmd-3.2 {FileCopyRename: not enough args} {notRoot} {
    list [catch {file rename xyz} msg] $msg
} {1 {wrong # args: should be "file rename ?options? source ?source ...? target"}}
test fCmd-3.3 {FileCopyRename: Tcl_TranslateFileName fails} {notRoot} {
    list [catch {file rename xyz ~nonexistantuser} msg] $msg
} {1 {user "nonexistantuser" doesn't exist}}
test fCmd-3.4 {FileCopyRename: Tcl_TranslateFileName passes} {notRoot} {
    cleanup
    list [catch {file copy tf1 ~} msg] $msg
} {1 {error copying "tf1": no such file or directory}}
test fCmd-3.5 {FileCopyRename: target doesn't exist: stat(target) != 0} {notRoot} {
    cleanup
    list [catch {file rename tf1 tf2 tf3} msg] $msg
} {1 {error renaming: target "tf3" is not a directory}}
test fCmd-3.6 {FileCopyRename: target tf3 is not a dir: !S_ISDIR(target)} \
	{notRoot} {
    cleanup
    createfile tf3
    list [catch {file rename tf1 tf2 tf3} msg] $msg
} {1 {error renaming: target "tf3" is not a directory}}
test fCmd-3.7 {FileCopyRename: target exists & is directory} {notRoot} {
    cleanup
    file mkdir td1
    createfile tf1 tf1
    file rename tf1 td1
    contents [file join td1 tf1]
} {tf1}
test fCmd-3.8 {FileCopyRename: too many arguments: argc - i > 2} {notRoot} {
    cleanup
    list [catch {file rename tf1 tf2 tf3} msg] $msg
} {1 {error renaming: target "tf3" is not a directory}}
test fCmd-3.9 {FileCopyRename: too many arguments: argc - i > 2} {notRoot} {
    cleanup
    list [catch {file copy -force -- tf1 tf2 tf3} msg] $msg
} {1 {error copying: target "tf3" is not a directory}}
test fCmd-3.10 {FileCopyRename: just 2 arguments} {notRoot} {
    cleanup
    createfile tf1 tf1
    file rename tf1 tf2
    contents tf2
} {tf1}
test fCmd-3.11 {FileCopyRename: just 2 arguments} {notRoot} {
    cleanup
    createfile tf1 tf1
    file rename -force -force -- tf1 tf2
    contents tf2
} {tf1}
test fCmd-3.12 {FileCopyRename: move each source: 1 source} {notRoot} {
    cleanup
    createfile tf1 tf1
    file mkdir td1
    file rename tf1 td1
    contents [file join td1 tf1]
} {tf1}
test fCmd-3.13 {FileCopyRename: move each source: multiple sources} {notRoot} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    createfile tf3 tf3
    createfile tf4 tf4
    file mkdir td1
    file rename tf1 tf2 tf3 tf4 td1
    list [contents [file join td1 tf1]] [contents [file join td1 tf2]] \
	[contents [file join td1 tf3]] [contents [file join td1 tf4]]
} {tf1 tf2 tf3 tf4}
test fCmd-3.14 {FileCopyRename: FileBasename fails} {notRoot} {
    cleanup
    file mkdir td1
    list [catch {file rename ~nonexistantuser td1} msg] $msg
} {1 {user "nonexistantuser" doesn't exist}}
test fCmd-3.15 {FileCopyRename: source[0] == '\0'} {notRoot unixOrPc} {
    cleanup
    file mkdir td1
    list [catch {file rename / td1} msg] $msg
} {1 {error renaming "/" to "td1": file already exists}}
test fCmd-3.16 {FileCopyRename: break on first error} {notRoot} {
    cleanup
    createfile tf1 
    createfile tf2 
    createfile tf3 
    createfile tf4 
    file mkdir td1
    createfile [file join td1 tf3]
    list [catch {file rename tf1 tf2 tf3 tf4 td1} msg] $msg
} [subst {1 {error renaming "tf3" to "[file join td1 tf3]": file already exists}}]

test fCmd-4.1 {TclFileMakeDirsCmd: make each dir: 1 dir} {notRoot} {
    cleanup
    file mkdir td1
    glob td*
} {td1}
test fCmd-4.2 {TclFileMakeDirsCmd: make each dir: multiple dirs} {notRoot} {
    cleanup
    file mkdir td1 td2 td3
    lsort [glob td*]
} {td1 td2 td3}
test fCmd-4.3 {TclFileMakeDirsCmd: stops on first error} {notRoot} {
    cleanup
    createfile tf1
    catch {file mkdir td1 td2 tf1 td3 td4}
    glob td1 td2 tf1 td3 td4
} {td1 td2 tf1}
test fCmd-4.4 {TclFileMakeDirsCmd: Tcl_TranslateFileName fails} {notRoot} {
    cleanup
    list [catch {file mkdir ~nonexistantuser} msg] $msg
} {1 {user "nonexistantuser" doesn't exist}}
test fCmd-4.5 {TclFileMakeDirsCmd: Tcl_SplitPath returns 0: *name == '\0'} \
	{notRoot} {
    cleanup
    list [catch {file mkdir ""} msg] $msg
} {1 {can't create directory "": no such file or directory}}
test fCmd-4.6 {TclFileMakeDirsCmd: one level deep} {notRoot} {
    cleanup
    file mkdir td1
    glob td1
} {td1}
test fCmd-4.7 {TclFileMakeDirsCmd: multi levels deep} {notRoot} {
    cleanup
    file mkdir [file join td1 td2 td3 td4]
    glob td1 [file join td1 td2]
} "td1 [file join td1 td2]"
test fCmd-4.8 {TclFileMakeDirsCmd: already exist: lstat(target) == 0} {notRoot} {
    cleanup
    file mkdir td1
    set x [file exist td1]
    file mkdir td1
    list $x [file exist td1]
} {1 1}
test fCmd-4.9 {TclFileMakeDirsCmd: exists, not dir} {notRoot} {
    cleanup
    createfile tf1
    list [catch {file mkdir tf1} msg] $msg
} [subst {1 {can't create directory "[file join tf1]": file already exists}}]
test fCmd-4.10 {TclFileMakeDirsCmd: exists, is dir} {notRoot} {
    cleanup
    file mkdir td1
    set x [file exist td1]
    file mkdir td1
    list $x [file exist td1]
} {1 1}












test fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} \
	{unixOnly notRoot} {
    cleanup
    file mkdir td1/td2/td3
    testchmod 000 td1/td2
    set msg [list [catch {file mkdir td1/td2/td3/td4} msg] $msg]
    testchmod 755 td1/td2
    set msg
} {1 {can't create directory "td1/td2/td3": permission denied}}
test fCmd-4.12 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} {macOnly} {
    cleanup
    list [catch {file mkdir nonexistantvolume:} msg] $msg
} {1 {can't create directory "nonexistantvolume:": invalid argument}}
test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} {notRoot} {
    cleanup
    set x [file exist td1]
    file mkdir td1
    list $x [file exist td1]
} {0 1}
test fCmd-4.14 {TclFileMakeDirsCmd: TclpCreateDirectory fails} \
	{unixOnly notRoot} {
    cleanup
    file delete -force foo
    file mkdir foo
    file attr foo -perm 040000
    set result [list [catch {file mkdir foo/tf1} msg] $msg]
    file delete -force foo
    set result
} {1 {can't create directory "foo/tf1": permission denied}}
test fCmd-4.15 {TclFileMakeDirsCmd: TclpCreateDirectory fails} {macOnly} {
    list [catch {file mkdir ${root}:} msg] $msg
} [subst {1 {can't create directory "${root}:": no such file or directory}}]
test fCmd-4.16 {TclFileMakeDirsCmd: TclpCreateDirectory succeeds} {notRoot} {
    cleanup
    file mkdir tf1
    file exists tf1
} {1}

test fCmd-5.1 {TclFileDeleteCmd: FileForceOption fails} {notRoot} {
    list [catch {file delete -xyz} msg] $msg
} {1 {bad option "-xyz": should be -force or --}}
test fCmd-5.2 {TclFileDeleteCmd: not enough args} {notRoot} {
    list [catch {file delete -force -force} msg] $msg
} {1 {wrong # args: should be "file delete ?options? file ?file ...?"}}
test fCmd-5.3 {TclFileDeleteCmd: 1 file} {notRoot} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    file delete tf2
    glob tf* td*
} {tf1 td1}
test fCmd-5.4 {TclFileDeleteCmd: multiple files} {notRoot} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    set x [list [file exist tf1] [file exist tf2] [file exist td1]]
    file delete tf1 td1 tf2
    lappend x [file exist tf1] [file exist tf2] [file exist tf3]
} {1 1 1 0 0 0}
test fCmd-5.5 {TclFileDeleteCmd: stop at first error} {notRoot unixOrPc} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    catch {file delete tf1 td1 $root tf2}
    list [file exist tf1] [file exist tf2] [file exist td1]
} {0 1 0}
test fCmd-5.6 {TclFileDeleteCmd: Tcl_TranslateFileName fails} {notRoot} {
    list [catch {file delete ~nonexistantuser} msg] $msg
} {1 {user "nonexistantuser" doesn't exist}}
test fCmd-5.7 {TclFileDeleteCmd: Tcl_TranslateFileName succeeds} {notRoot} {
    catch {file delete ~/tf1}
    createfile ~/tf1
    file delete ~/tf1
} {}
test fCmd-5.8 {TclFileDeleteCmd: file doesn't exist: lstat(name) != 0} {notRoot} {
    cleanup
    set x [file exist tf1]
    file delete tf1
    list $x [file exist tf1]
} {0 0}    
test fCmd-5.9 {TclFileDeleteCmd: is directory} {notRoot} {
    cleanup
    file mkdir td1
    file delete td1
    file exist td1
} {0}
test fCmd-5.10 {TclFileDeleteCmd: TclpRemoveDirectory fails} {notRoot} {
    cleanup
    file mkdir td1/td2
    list [catch {file delete td1} msg] $msg
} {1 {error deleting "td1": directory not empty}}

test fCmd-6.1 {CopyRenameOneFile: bad source} {notRoot} {
    # can't test this, because it's caught by FileCopyRename
} {}
test fCmd-6.2 {CopyRenameOneFile: bad target} {notRoot} {
    # can't test this, because it's caught by FileCopyRename
} {}
test fCmd-6.3 {CopyRenameOneFile: lstat(source) != 0} {notRoot} {
    cleanup
    list [catch {file rename tf1 tf2} msg] $msg
} {1 {error renaming "tf1": no such file or directory}}
test fCmd-6.4 {CopyRenameOneFile: lstat(source) == 0} {notRoot} {
    cleanup
    createfile tf1
    file rename tf1 tf2
    glob tf*
} {tf2}
test fCmd-6.5 {CopyRenameOneFile: lstat(target) != 0} {notRoot} {
    cleanup
    createfile tf1
    file rename tf1 tf2
    glob tf*
} {tf2}






test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} {unixOnly notRoot} {
    cleanup
    file mkdir td1
    testchmod 000 td1
    createfile tf1
    set msg [list [catch {file rename tf1 td1} msg] $msg]
    testchmod 755 td1
    set msg
................................................................................
    list [catch {file rename tf1 $long} msg] $msg
} [subst {1 {error renaming "tf1" to "$long": file name too long}}]
test fCmd-6.8 {CopyRenameOneFile: errno != ENOENT} {macOnly} {
    cleanup
    createfile tf1
    list [catch {file rename tf1 $long} msg] $msg
} [subst {1 {error renaming "tf1" to "$long": file name too long}}]
test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} {unixOnly notRoot} {
    cleanup
    createfile tf1
    file rename tf1 tf2
    glob tf*
} {tf2}
test fCmd-6.10 {CopyRenameOneFile: lstat(target) == 0} {notRoot} {
    cleanup
    createfile tf1
    createfile tf2
    list [catch {file rename tf1 tf2} msg] $msg
} {1 {error renaming "tf1" to "tf2": file already exists}}
test fCmd-6.11 {CopyRenameOneFile: force == 0} {notRoot} {
    cleanup
    createfile tf1
    createfile tf2
    list [catch {file rename tf1 tf2} msg] $msg
} {1 {error renaming "tf1" to "tf2": file already exists}}
test fCmd-6.12 {CopyRenameOneFile: force != 0} {notRoot} {
    cleanup
    createfile tf1
    createfile tf2
    file rename -force tf1 tf2
    glob tf*
} {tf2}
test fCmd-6.13 {CopyRenameOneFile: source is dir, target is file} {notRoot} {
    cleanup
    file mkdir td1
    file mkdir td2
    createfile [file join td2 td1]
    list [catch {file rename -force td1 td2} msg] $msg
} [subst {1 {can't overwrite file "[file join td2 td1]" with directory "td1"}}]
test fCmd-6.14 {CopyRenameOneFile: source is file, target is dir} {notRoot} {
    cleanup
    createfile tf1
    file mkdir [file join td1 tf1]
    list [catch {file rename -force tf1 td1} msg] $msg
} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}]
test fCmd-6.15 {CopyRenameOneFile: TclpRenameFile succeeds} {notRoot} {
    cleanup
    file mkdir [file join td1 td2]
    file mkdir td2
    createfile [file join td2 tf1]
    file rename -force td2 td1
    file exists [file join td1 td2 tf1]
} {1}
test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} {notRoot} {
    cleanup
    file mkdir [file join td1 td2]
    createfile [file join td1 td2 tf1]
    file mkdir td2
    list [catch {file rename -force td2 td1} msg] $msg
} [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}]




test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} {notRoot} {
    cleanup
    list [catch {file rename -force $root tf1} msg] $msg
} [subst {1 {error renaming "$root" to "tf1": trying to rename a volume or move a directory into itself}}]
test fCmd-6.18 {CopyRenameOneFile: errno != EXDEV} {notRoot} {
    cleanup
    file mkdir [file join td1 td2]
    createfile [file join td1 td2 tf1]
    file mkdir td2
    list [catch {file rename -force td2 td1} msg] $msg
} [subst {1 {error renaming "td2" to "[file join td1 td2]": file already exists}}]
test fCmd-6.19 {CopyRenameOneFile: errno == EXDEV} {unixOnly notRoot} {
    cleanup /tmp
    createfile tf1
    file rename tf1 /tmp
    glob tf* /tmp/tf1
} {/tmp/tf1}
test fCmd-6.20 {CopyRenameOneFile: errno == EXDEV} {pcOnly} {
    catch {file delete -force c:/[email protected] d:/[email protected]}
................................................................................
	list d:/[email protected]
    } else {
	set msg [glob c:/[email protected] d:/[email protected]]
	file delete -force d:/[email protected]
	set msg
    }
} {d:/[email protected]}
test fCmd-6.21 {CopyRenameOneFile: copy/rename: S_ISDIR(source)} \
	{unixOnly notRoot} {
    cleanup /tmp
    file mkdir td1
    file rename td1 /tmp
    glob td* /tmp/td*
} {/tmp/td1}
test fCmd-6.22 {CopyRenameOneFile: copy/rename: !S_ISDIR(source)} \
	{unixOnly notRoot} {
    cleanup /tmp
    createfile tf1
    file rename tf1 /tmp
    glob tf* /tmp/tf*
} {/tmp/tf1}
test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} \
	{unixOnly notRoot xdev} {
    cleanup /tmp
    file mkdir td1/td2/td3
    exec chmod 000 td1
    set msg [list [catch {file rename td1 /tmp} msg] $msg]
    exec chmod 755 td1
    set msg 
} {1 {error renaming "td1": permission denied}}
test fCmd-6.24 {CopyRenameOneFile: error uses original name} \
	{unixOnly notRoot} {
    cleanup
    file mkdir ~/td1/td2
    exec chmod 000 [file join [file dirname ~] [file tail ~] td1]
    set msg [list [catch {file copy ~/td1 td1} msg] $msg]
    exec chmod 755 [file join [file dirname ~] [file tail ~] td1]
    file delete -force ~/td1
    set msg
} {1 {error copying "~/td1": permission denied}}
test fCmd-6.25 {CopyRenameOneFile: error uses original name} \
	{unixOnly notRoot} {
    cleanup
    file mkdir td2
    file mkdir ~/td1
    exec chmod 000 [file join [file dirname ~] [file tail ~] td1]
    set msg [list [catch {file copy td2 ~/td1} msg] $msg]
    exec chmod 755 [file join [file dirname ~] [file tail ~] td1]
    file delete -force ~/td1
    set msg
} {1 {error copying "td2" to "~/td1/td2": permission denied}}
test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} \
	{unixOnly notRoot} {
    cleanup
    file mkdir ~/td1/td2
    exec chmod 000 [file join [file dirname ~] [file tail ~] td1 td2]
    set msg [list [catch {file copy ~/td1 td1} msg] $msg]
    exec chmod 755 [file join [file dirname ~] [file tail ~] td1 td2]
    file delete -force ~/td1
    set msg
} "1 {error copying \"~/td1\" to \"td1\": \"[file join [file dirname ~] [file tail ~] td1 td2]\": permission denied}"
test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} \
	{unixOnly notRoot xdev} {
    cleanup /tmp
    file mkdir td1/td2/td3
    file mkdir /tmp/td1
    createfile /tmp/td1/tf1
    list [catch {file rename -force td1 /tmp} msg] $msg
} {1 {error renaming "td1" to "/tmp/td1": file already exists}}
test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} \
	{unixOnly notRoot xdev} {
    cleanup /tmp
    file mkdir td1/td2/td3
    exec chmod 000 td1/td2/td3 
    set msg [list [catch {file rename td1 /tmp} msg] $msg]
    exec chmod 755 td1/td2/td3 
    set msg
} {1 {error renaming "td1" to "/tmp/td1": "td1/td2/td3": permission denied}}
test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} \
	{unixOnly notRoot xdev} {
    cleanup /tmp
    file mkdir td1/td2/td3
    file rename td1 /tmp
    glob td* /tmp/td1/t*
} {/tmp/td1/td2}
test fCmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} \
	{unixOnly notRoot} {
    cleanup
    file mkdir foo/bar
    file attr foo -perm 040555
    set msg [list [catch {file rename foo/bar /tmp} msg] $msg]
    catch {file delete /tmp/bar}
    catch {file attr foo -perm 040777}
    catch {file delete -force foo}
    set msg
} {1 {can't unlink "foo/bar": permission denied}}
test fCmd-6.31 {CopyRenameOneFile: TclpDeleteFile passed} \
	{unixOnly notRoot xdev} {
    catch {cleanup /tmp}
    file mkdir /tmp/td1
    createfile /tmp/td1/tf1
    file rename /tmp/td1/tf1 tf1
    list [file exists /tmp/td1/tf1] [file exists tf1]
} {0 1}
test fCmd-6.32 {CopyRenameOneFile: copy} {notRoot} {
    cleanup
    list [catch {file copy tf1 tf2} msg] $msg
} {1 {error copying "tf1": no such file or directory}}
catch {cleanup /tmp}

test fCmd-7.1 {FileForceOption: none} {notRoot} {
    cleanup
    file mkdir [file join tf1 tf2]
    list [catch {file delete tf1} msg] $msg
} {1 {error deleting "tf1": directory not empty}}
test fCmd-7.2 {FileForceOption: -force} {notRoot} {
    cleanup
    file mkdir [file join tf1 tf2]
    file delete -force tf1
} {}
test fCmd-7.3 {FileForceOption: --} {notRoot} {
    createfile -tf1
    file delete -- -tf1
} {}
test fCmd-7.4 {FileForceOption: bad option} {notRoot} {
    createfile -tf1
    set msg [list [catch {file delete -tf1} msg] $msg]
    file delete -- -tf1
    set msg
} {1 {bad option "-tf1": should be -force or --}}
test fCmd-7.5 {FileForceOption: multiple times through loop} {notRoot} {
    createfile --
    createfile -force
    file delete -force -force -- -- -force
    list [catch {glob -- -- -force} msg] $msg
} {1 {no files matched glob patterns "-- -force"}}

test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \
	{unixOnly notRoot} {
    file mkdir td1
    file attr td1 -perm 040000
    set result [list [catch {file rename ~$user td1} msg] $msg]
    file delete -force td1
    set result
} "1 {error renaming \"~$user\" to \"td1/[file tail ~$user]\": permission denied}"

test fCmd-9.1 {file rename: comprehensive: EACCES} {unixOnly notRoot} {
    cleanup
    file mkdir td1
    file mkdir td2
    file attr td2 -perm 040000
    set result [list [catch {file rename td1 td2/} msg] $msg]
    file delete -force td2
    file delete -force td1
    set result
} {1 {error renaming "td1" to "td2/td1": permission denied}}
test fCmd-9.2 {file rename: comprehensive: source doesn't exist} {notRoot} {
    cleanup
    list [catch {file rename tf1 tf2} msg] $msg
} {1 {error renaming "tf1": no such file or directory}}
test fCmd-9.3 {file rename: comprehensive: file to new name} {notRoot} {
    cleanup
    createfile tf1
    createfile tf2
    testchmod 444 tf2
    file rename tf1 tf3
    file rename tf2 tf4
    list [lsort [glob tf*]] [file writable tf3] [file writable tf4]
} {{tf3 tf4} 1 0}    
test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc notRoot} {
    cleanup
    file mkdir td1 td2
    testchmod 555 td2
    file rename td1 td3
    file rename td2 td4
    list [lsort [glob td*]] [file writable td3] [file writable td4]
} {{td3 td4} 1 0}    
test fCmd-9.5 {file rename: comprehensive: file to self} {notRoot} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    testchmod 444 tf2
    file rename -force tf1 tf1
    file rename -force tf2 tf2
    list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2]
} {tf1 tf2 1 0}    
test fCmd-9.6 {file rename: comprehensive: dir to self} {notRoot unixOrPc} {
    cleanup
    file mkdir td1
    file mkdir td2
    testchmod 555 td2
    file rename -force td1 .
    file rename -force td2 .
    list [lsort [glob td*]] [file writable td1] [file writable td2]
} {{td1 td2} 1 0}    
test fCmd-9.7 {file rename: comprehensive: file to existing file} {notRoot} {
    cleanup
    createfile tf1
    createfile tf2
    createfile tfs1
    createfile tfs2
    createfile tfs3
    createfile tfs4
................................................................................
    set msg [list [catch {file rename tf1 tf2} msg] $msg]
    file rename -force tfs1 tfd1
    file rename -force tfs2 tfd2
    file rename -force tfs3 tfd3
    file rename -force tfs4 tfd4
    list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] 
} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0}
test fCmd-9.8 {file rename: comprehensive: dir to empty dir} {notRoot} {
    # Under unix, you can rename a read-only directory, but you can't
    # move it into another directory.

    cleanup
    file mkdir td1
    file mkdir [file join td2 td1]
    file mkdir tds1
................................................................................
    } else {
	set w3 0
	set w4 0
    }
    list [lsort [glob td*]] $msg [file writable [file join tdd1 tds1]] \
    [file writable [file join tdd2 tds2]] $w3 $w4
} [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4} {1 {error renaming "td1" to "[file join td2 td1]": file already exists}} 1 1 0 0}]
test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} {notRoot} {
    cleanup
    file mkdir tds1
    file mkdir tds2
    file mkdir [file join tdd1 tds1 xxx]
    file mkdir [file join tdd2 tds2 xxx]
    if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} {
	testchmod 555 tds2
................................................................................
    if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} {
	set w2 [file writable tds2]
    } else {
	set w2 0
    }
    list [lsort [glob td*]] $a1 $a2 [file writable tds1] $w2
} [subst {{tdd1 tdd2 tds1 tds2} {1 {error renaming "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error renaming "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}]
test fCmd-9.10 {file rename: comprehensive: file to new name and dir} {notRoot} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    testchmod 444 tf2
    file rename tf1 [file join td1 tf3]
    file rename tf2 [file join td1 tf4]
    list [catch {glob tf*}] [lsort [glob [file join td1 t*]]] \
    [file writable [file join td1 tf3]] [file writable [file join td1 tf4]]
} [subst {1 {[file join td1 tf3] [file join td1 tf4]} 1 0}]
test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} {notRoot} {
    cleanup
    file mkdir td1
    file mkdir td2
    file mkdir td3
    if {$tcl_platform(platform) != "unix" && $tcl_platform(platform) != "macintosh"} {
	testchmod 555 td2
    }
................................................................................
	set w4 [file writable [file join td3 td4]]
    } else {
        set w4 0
    }
    list [lsort [glob td*]] [lsort [glob [file join td3 t*]]] \
    [file writable [file join td3 td3]] $w4
} [subst {td3 {[file join td3 td3] [file join td3 td4]} 1 0}]
test fCmd-9.12 {file rename: comprehensive: target exists} {notRoot} {
    cleanup
    file mkdir [file join td1 td2] [file join td2 td1]
    if {$tcl_platform(platform) != "macintosh"} {
    	testchmod 555 [file join td2 td1]
    }
    file mkdir [file join td3 td4] [file join td4 td3]
    file rename -force td3 td4
................................................................................
    set msg [list [file exists td3] [file exists [file join td4 td3 td4]] \
    [catch {file rename td1 td2} msg] $msg]
    if {$tcl_platform(platform) != "macintosh"} {
    	testchmod 755 [file join td2 td1]
    }
    set msg
} [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}]
test fCmd-9.13 {file rename: comprehensive: can't overwrite target} {notRoot} {
    cleanup
    file mkdir [file join td1 td2] [file join td2 td1 td4]
    list [catch {file rename -force td1 td2} msg] $msg
} [subst {1 {error renaming "td1" to "[file join td2 td1]": file already exists}}]
test fCmd-9.14 {file rename: comprehensive: dir into self} {notRoot} {
    cleanup
    file mkdir td1
    list [glob td*] [list [catch {file rename td1 td1} msg] $msg]
} [subst {td1 {1 {error renaming "td1" to "[file join td1 td1]": trying to rename a volume or move a directory into itself}}}]
test fCmd-9.15 {file rename: comprehensive: source and target incompatible} \
	{notRoot} {
    cleanup
    file mkdir td1
    createfile tf1
    list [catch {file rename -force td1 tf1} msg] $msg
} {1 {can't overwrite file "tf1" with directory "td1"}}
test fCmd-9.16 {file rename: comprehensive: source and target incompatible} \
	{notRoot} {
    cleanup
    file mkdir td1/tf1
    createfile tf1
    list [catch {file rename -force tf1 td1} msg] $msg
} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}]

test fCmd-10.1 {file copy: comprehensive: source doesn't exist} {notRoot} {
    cleanup
    list [catch {file copy tf1 tf2} msg] $msg
} {1 {error copying "tf1": no such file or directory}}
test fCmd-10.2 {file copy: comprehensive: file to new name} {notRoot} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    testchmod 444 tf2
    file copy tf1 tf3
    file copy tf2 tf4
    list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4]
} {{tf1 tf2 tf3 tf4} tf1 tf2 1 0}
test fCmd-10.3 {file copy: comprehensive: dir to new name} {notRoot unixOrPc} {
    cleanup
    file mkdir [file join td1 tdx]
    file mkdir [file join td2 tdy]
    testchmod 555 td2
    file copy td1 td3
    file copy td2 td4
    set msg [list [lsort [glob td*]] [glob [file join td3 t*]] \
................................................................................
	    [glob [file join td4 t*]] [file writable td3] [file writable td4]]
    if {$tcl_platform(platform) != "macintosh"} {
    	testchmod 755 td2
    	testchmod 755 td4
    }
    set msg
} [subst {{td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0}]
test fCmd-10.4 {file copy: comprehensive: file to existing file} {notRoot} {
    cleanup
    createfile tf1
    createfile tf2
    createfile tfs1
    createfile tfs2
    createfile tfs3
    createfile tfs4
................................................................................
    set msg [list [catch {file copy tf1 tf2} msg] $msg]
    file copy -force tfs1 tfd1
    file copy -force tfs2 tfd2
    file copy -force tfs3 tfd3
    file copy -force tfs4 tfd4
    list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] 
} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4 tfs1 tfs2 tfs3 tfs4} {1 {error copying "tf1" to "tf2": file already exists}} 1 1 0 0}
test fCmd-10.5 {file copy: comprehensive: dir to empty dir} {notRoot} {
    cleanup
    file mkdir td1
    file mkdir [file join td2 td1]
    file mkdir tds1
    file mkdir tds2
    file mkdir tds3
    file mkdir tds4
................................................................................
    set a1 [list [catch {file copy td1 td2} msg] $msg]
    set a2 [list [catch {file copy -force tds1 tdd1} msg] $msg]
    set a3 [catch {file copy -force tds2 tdd2}]
    set a4 [catch {file copy -force tds3 tdd3}]
    set a5 [catch {file copy -force tds4 tdd4}]
    list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5 
} [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}]
test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} \
	{notRoot unixOrPc} {
    cleanup
    file mkdir tds1
    file mkdir tds2
    file mkdir [file join tdd1 tds1 xxx]
    file mkdir [file join tdd2 tds2 xxx]
    testchmod 555 tds2
    set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg]
    set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg]
    list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2]
} [subst {{tdd1 tdd2 tds1 tds2} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error copying "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}]
test fCmd-10.7 {file rename: comprehensive: file to new name and dir} {notRoot} {
    cleanup
    createfile tf1
    createfile tf2
    file mkdir td1
    testchmod 444 tf2
    file copy tf1 [file join td1 tf3]
    file copy tf2 [file join td1 tf4]
    list [lsort [glob tf*]] [lsort [glob [file join td1 t*]]] \
    [file writable [file join td1 tf3]] [file writable [file join td1 tf4]]
} [subst {{tf1 tf2} {[file join td1 tf3] [file join td1 tf4]} 1 0}]
test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} \
	{notRoot unixOrPc} {
    cleanup
    file mkdir td1
    file mkdir td2
    file mkdir td3
    testchmod 555 td2
    file copy td1 [file join td3 td3]
    file copy td2 [file join td3 td4]
    list [lsort [glob td*]] [lsort [glob [file join td3 t*]]] \
    [file writable [file join td3 td3]] [file writable [file join td3 td4]]
} [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 0}]
test fCmd-10.9 {file copy: comprehensive: source and target incompatible} \
	{notRoot} {
    cleanup
    file mkdir td1
    createfile tf1
    list [catch {file copy -force td1 tf1} msg] $msg
} {1 {can't overwrite file "tf1" with directory "td1"}}
test fCmd-10.10 {file copy: comprehensive: source and target incompatible} \
	{notRoot} {
    cleanup
    file mkdir [file join td1 tf1]
    createfile tf1
    list [catch {file copy -force tf1 td1} msg] $msg
} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}]
cleanup    

# old tests    

test fCmd-11.1 {TclFileRenameCmd: -- option } {notRoot} {
    catch {file delete -force -- -tfa1}
    set s [createfile -tfa1]
    file rename -- -tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] && ![file exists -tfa1]]
    file delete tfa2
    set result
} {1}

test fCmd-11.2 {TclFileRenameCmd: bad option } {notRoot} {
    catch {file delete -force -- tfa1}
    set s [createfile tfa1]
    set r1 [catch {file rename -x tfa1 tfa2}]
    set result [expr $r1 && [checkcontent tfa1 $s] && ![file exists tfa2]]
    file delete tfa1
    set result
} {1}

test fCmd-11.3 {TclFileRenameCmd: bad \# args} {
    catch {file rename -- }
} {1}

test fCmd-11.4 {TclFileRenameCmd: target filename translation failing} {notRoot} {
     global env
     set temp $env(HOME)
     unset env(HOME)
     set result [catch {file rename tfa ~/foobar }]
     set env(HOME) $temp
     set result
 } {1}

test fCmd-11.5 {TclFileRenameCmd: > 1 source & target is not a dir} {notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
    createfile tfa1 
    createfile tfa2 
    createfile tfa3 
    set result [catch {file rename tfa1 tfa2 tfa3}]
    file delete tfa1 tfa2 tfa3
    set result
} {1}

test fCmd-11.6 {TclFileRenameCmd: : single file into directory} {notRoot} {
    catch {file delete -force -- tfa1 tfad}
    set s [createfile tfa1]
    file mkdir tfad
    file rename tfa1 tfad
    set result [expr [checkcontent tfad/tfa1 $s] && ![file exists tfa1]]
    file delete -force tfad
    set result
} {1}

test fCmd-11.7 {TclFileRenameCmd: : multiple files into directory} {notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfad}
    set s1 [createfile tfa1 ]
    set s2 [createfile tfa2 ]
    file mkdir tfad
    file rename tfa1 tfa2 tfad
    set r1 [checkcontent tfad/tfa1 $s1]
    set r2 [checkcontent tfad/tfa2 $s2]
................................................................................
    
    set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfa2]]
	    
    file delete -force tfad
    set result
} {1}

test fCmd-11.8 {TclFileRenameCmd: error renaming file to directory} {notRoot} {
    catch {file delete -force -- tfa tfad}
    set s [createfile tfa ]
    file mkdir tfad
    file mkdir tfad/tfa
    set r1 [catch {file rename tfa tfad}]
    set r2 [checkcontent tfa $s]
    set r3 [file isdir tfad]
................................................................................
    file delete -force tfa tfad
    set result
} {1}

#
# Coverage tests for renamefile() ;
#
test fCmd-12.1 {renamefile: source filename translation failing} {notRoot} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set result [catch {file rename ~/tfa1 tfa2}]
    set env(HOME) $temp
    set result
} {1}

test fCmd-12.2 {renamefile: src filename translation failing} {notRoot} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set s [createfile tfa1]
    file mkdir tfad
    set result [catch {file rename tfa1 ~/tfa2 tfad}]
    set env(HOME) $temp
    file delete -force tfad
    set result
} {1}

test fCmd-12.3 {renamefile: stat failing on source} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    set r1 [catch {file rename tfa1 tfa2}]
    expr {$r1 && ![file exists tfa1] && ![file exists tfa2]}
} {1}

test fCmd-12.4 {renamefile: error renaming file to directory} {notRoot} {
    catch {file delete -force -- tfa tfad}
    set s1 [createfile tfa ]
    file mkdir tfad
    file mkdir tfad/tfa
    set r1 [catch {file rename tfa tfad}]
    set r2 [checkcontent tfa $s1]
    set r3 [file isdir tfad/tfa]
    set result [expr $r1 && $r2 && $r3]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-12.5 {renamefile: error renaming directory to file} {notRoot} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa
    file mkdir tfad
    set s [createfile tfad/tfa]
    set r1 [catch {file rename tfa tfad}]
    set r2 [checkcontent tfad/tfa $s]
    set r3 [file isdir tfad]
    set r4 [file isdir tfa]
    set result [expr $r1 && $r2 && $r3 && $r4 ]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-12.6 {renamefile: TclRenameFile succeeding} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    set s [createfile tfa1]
    file rename tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] && ![file exists tfa1]]
    file delete tfa2
    set result
} {1}

test fCmd-12.7 {renamefile: renaming directory into offspring} {notRoot} {
    catch {file delete -force -- tfad}
    file mkdir tfad
    file mkdir tfad/dir
    set result [catch {file rename tfad tfad/dir}]
    file delete -force tfad 
    set result
} {1}

test fCmd-12.8 {renamefile: generic error} {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/dir
    exec chmod 555 tfa
    set result [catch {file rename tfa/dir tfa2}]
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}


test fCmd-12.9 {renamefile: moving a file across volumes} {unixOnly notRoot} {
    catch {file delete -force -- tfa /tmp/tfa}
    set s [createfile tfa ]
    file rename tfa /tmp
    set result [expr [checkcontent /tmp/tfa $s] && ![file exists tfa]]
    file delete /tmp/tfa
    set result
} {1}

test fCmd-12.10 {renamefile: moving a directory across volumes } \
	{unixOnly notRoot} {
    catch {file delete -force -- tfad /tmp/tfad}
    file mkdir tfad
    set s [createfile tfad/a ]
    file rename tfad /tmp
    set restul [expr [checkcontent /tmp/tfad/a $s] && ![file exists tfad]]
    file delete -force /tmp/tfad
    set result
} {1}

#
# Coverage tests for TclCopyFilesCmd()
#
test fCmd-13.1 {TclCopyFilesCmd: -force option} {notRoot} {
    catch {file delete -force -- tfa1}
    set s [createfile tfa1]
    file copy -force  tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] && [checkcontent tfa1 $s]]
    file delete tfa1 tfa2
    set result
} {1}

test fCmd-13.2 {TclCopyFilesCmd: -- option} {notRoot} {
    catch {file delete -force -- tfa1}
    set s [createfile -tfa1]
    file copy --  -tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] &&  [checkcontent -tfa1 $s]]
    file delete -- -tfa1 tfa2
    set result
} {1}

test fCmd-13.3 {TclCopyFilesCmd: bad option} {notRoot} {
    catch {file delete -force -- tfa1}
    set s [createfile tfa1]
    set r1 [catch {file copy -x tfa1 tfa2}]
    set result [expr $r1 && [checkcontent tfa1 $s] && ![file exists tfa2]]
    file delete tfa1
    set result
} {1}

test fCmd-13.4 {TclCopyFilesCmd: bad \# args} {notRoot} {
    catch {file copy -- }
} {1}

test fCmd-13.5 {TclCopyFilesCmd: target filename translation failing} {
     global env
     set temp $env(HOME)
    unset env(HOME)
     set result [catch {file copy tfa ~/foobar }]
     set env(HOME) $temp
     set result
 } {1}

test fCmd-13.6 {TclCopyFilesCmd: > 1 source & target is not a dir} {notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
    createfile tfa1 
    createfile tfa2 
    createfile tfa3 
    set result [catch {file copy tfa1 tfa2 tfa3}]
    file delete tfa1 tfa2 tfa3
    set result
} {1}

test fCmd-13.7 {TclCopyFilesCmd: single file into directory} {notRoot} {
    catch {file delete -force -- tfa1 tfad}
    set s [createfile tfa1]
    file mkdir tfad
    file copy tfa1 tfad
    set result [expr [checkcontent tfad/tfa1 $s] &&  [checkcontent tfa1 $s]]
    file delete -force tfad tfa1
    set result
} {1}

test fCmd-13.8 {TclCopyFilesCmd: multiple files into directory} {notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfad}
    set s1 [createfile tfa1 ]
    set s2 [createfile tfa2 ]
    file mkdir tfad
    file copy tfa1 tfa2 tfad
    set r1 [checkcontent tfad/tfa1 $s1]
    set r2 [checkcontent tfad/tfa2 $s2]
................................................................................
    set r4 [checkcontent tfa2 $s2]
    set result [expr $r1 && $r2 && $r3 && $r4 ]
	    
    file delete -force tfad tfa1 tfa2
    set result
} {1}

test fCmd-13.9 {TclCopyFilesCmd: error copying file to directory} {notRoot} {
    catch {file delete -force -- tfa tfad}
    set s [createfile tfa ]
    file mkdir tfad
    file mkdir tfad/tfa
    set r1 [catch {file copy tfa tfad}]
    set r2 [expr [checkcontent tfa $s] && [file isdir tfad/tfa]]
    set r3 [file isdir tfad]
................................................................................
    file delete -force tfa tfad
    set result
} {1}

#
# Coverage tests for copyfile()
# 
test fCmd-14.1 {copyfile: source filename translation failing} {notRoot} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set result [catch {file copy ~/tfa1 tfa2}]
    set env(HOME) $temp
    set result
} {1}

test fCmd-14.2 {copyfile: dst filename translation failing} {notRoot} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set s [createfile tfa1]
    file mkdir tfad
    set r1 [catch {file copy tfa1 ~/tfa2 tfad}]
    set result [expr $r1 && [checkcontent tfad/tfa1 $s]]
    set env(HOME) $temp
    file delete -force tfa1 tfad
    set result
} {1}

test fCmd-14.3 {copyfile: stat failing on source} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    set r1 [catch {file copy tfa1 tfa2}]
    expr $r1 && ![file exists tfa1] && ![file exists tfa2]
} {1}

test fCmd-14.4 {copyfile: error copying file to directory} {notRoot} {
    catch {file delete -force -- tfa tfad}
    set s1 [createfile tfa ]
    file mkdir tfad
    file mkdir tfad/tfa
    set r1 [catch {file copy tfa tfad}]
    set r2 [checkcontent tfa $s1]
    set r3 [file isdir tfad]
    set r4 [file isdir tfad/tfa]
    set result [expr $r1 && $r2 && $r3 && $r4 ]
    file delete -force tfa tfad
    set result
} {1}

 test fCmd-14.5 {copyfile: error copying directory to file} {notRoot} {
     catch {file delete -force -- tfa tfad}
     file mkdir tfa
     file mkdir tfad
     set s [createfile tfad/tfa]
     set r1 [catch {file copy tfa tfad}]
     set r2 [checkcontent tfad/tfa $s]
     set r3 [file isdir tfad]
     set r4 [file isdir tfa]
     set result [expr $r1 && $r2 && $r3 && $r4 ]
     file delete -force tfa tfad
     set result
} {1}

test fCmd-14.6 {copyfile: copy file succeeding} {notRoot} {
    catch {file delete -force -- tfa tfa2}
    set s [createfile tfa]
    file copy tfa tfa2
    set result [expr  [checkcontent tfa $s] && [checkcontent tfa2 $s]]
    file delete tfa tfa2
    set result
} {1}

test fCmd-14.7 {copyfile: copy directory succeeding} {notRoot} {
    catch {file delete -force -- tfa tfa2}
    file mkdir tfa
    set s [createfile tfa/file]
    file copy tfa tfa2
    set result [expr [checkcontent tfa/file $s] && [checkcontent tfa2/file $s]]
    file delete -force tfa tfa2
    set result
} {1}

test fCmd-14.8 {copyfile: copy directory failing} {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa/dir/a/b/c
    exec chmod 000 tfa/dir
    set r1 [catch {file copy tfa tfa2}]
    exec chmod 777 tfa/dir
    set result $r1
    file delete -force tfa tfa2
    set result
} {1}

#
# Coverage tests for TclMkdirCmd()
#
test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} {notRoot} {
    global env
    set temp $env(HOME)
    unset env(HOME) 
    set result [catch {file mkdir ~/tfa}]
    set env(HOME) $temp
    set result
} {1}
#
# Can Tcl_SplitPath return argc == 0? If so them we need a
# test for that code.
#
test fCmd-15.2 {TclMakeDirsCmd - one directory } {notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    set result [file isdirectory tfa]
    file delete tfa
    set result
} {1}

test fCmd-15.3 {TclMakeDirsCmd: - two directories} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    file mkdir tfa1 tfa2
    set result [expr [file isdirectory tfa1] && [file isdirectory tfa2]]
    file delete tfa1 tfa2
    set result
} {1}

test fCmd-15.4 {TclMakeDirsCmd - stat failing} {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/file
    exec chmod 000 tfa
    set result [catch {file mkdir tfa/file}]
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}

test fCmd-15.5 {TclMakeDirsCmd: - making a directory several levels deep} \
	{notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa/a/b/c
    set result [file isdir tfa/a/b/c]
    file delete -force tfa
    set result
} {1}

    
test fCmd-15.6 {TclMakeDirsCmd: - trying to overwrite a file} {notRoot} {
    catch {file delete -force -- tfa}
    set s [createfile tfa]
    set r1 [catch {file mkdir tfa}]
    set r2 [file isdir tfa]
    set r3 [file exists tfa]
    set result [expr $r1 && !$r2 && $r3 && [checkcontent tfa $s]]
    file delete tfa
    set result
} {1}

test fCmd-15.7 {TclMakeDirsCmd - making several directories} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    file mkdir tfa1 tfa2/a/b/c
    set result [expr [file isdir tfa1] && [file isdir tfa2/a/b/c]]
    file delete -force tfa1 tfa2
    set result
} {1}

test fCmd-15.8 {TclFileMakeDirsCmd: trying to create an existing dir} {notRoot} {
    file mkdir tfa
    file mkdir tfa
    set result [file isdir tfa]
    file delete tfa
    set result
} {1}


# Coverage tests for TclDeleteFilesCommand()
test fCmd-16.1 { test the -- argument } {notRoot} {
    catch {file delete -force -- tfa}
    createfile tfa
    file delete -- tfa
    file exists tfa
} {0}

test fCmd-16.2 { test the -force and -- arguments } {notRoot} {
    catch {file delete -force -- tfa}
    createfile tfa
    file delete -force -- tfa
    file exists tfa
} {0}

test fCmd-16.3 { test bad option } {notRoot} {
    catch {file delete -force -- tfa}
    createfile tfa
    set result [catch {file delete -dog tfa}]
    file delete tfa
    set result
} {1}

test fCmd-16.4 { test not enough args } {notRoot} {
    catch {file delete}
} {1}

test fCmd-16.5 { test not enough args with options } {notRoot} {
    catch {file delete --}
} {1}

test fCmd-16.6 {delete: source filename translation failing} {notRoot} {
    global env
    set temp $env(HOME)
    unset env(HOME)
    set result [catch {file delete ~/tfa}]
    set env(HOME) $temp
    set result
} {1}

test fCmd-16.7 {remove a non-empty directory without -force } {notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/a
    set result [catch  {file delete tfa }]
    file delete -force tfa
    set result
} {1}

test fCmd-16.8 {remove a normal file } {notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/a
    set result [catch  {file delete tfa }]
    file delete -force tfa
    set result
} {1}

test fCmd-16.9 {error while deleting file } {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/a
    exec chmod 555 tfa
    set result [catch  {file delete tfa/a }]
    #######
    #######  If any directory in a tree that is being removed does not 
................................................................................
    #######  This is also the case with "rm -rf"
    #######
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}

test fCmd-16.10 {deleting multiple files} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    createfile tfa1
    createfile tfa2
    file delete tfa1 tfa2
    expr ![file exists tfa1] && ![file exists tfa2]
} {1}

test fCmd-16.11 { TclFileDeleteCmd: removing a nonexistant file} {notRoot} {
    catch {file delete -force -- tfa}
    file delete tfa
    set result 1
} {1}

# More coverage tests for mkpath()
 test fCmd-17.1 {mkdir stat failing on target but not ENOENT} {unixOnly notRoot} {
     catch {file delete -force -- tfa1}
     file mkdir tfa1
     exec chmod 555 tfa1
     set result [catch {file mkdir tfa1/tfa2}]
     exec chmod 777 tfa1
     file delete -force tfa1
     set result
} {1}

test fCmd-17.2 {mkdir several levels deep - relative } {notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa/a/b
    set result [file isdir tfa/a/b ]
    file delete tfa/a/b tfa/a tfa
    set result
} {1}

test fCmd-17.3 {mkdir several levels deep - absolute } {notRoot} {
    catch {file delete -force -- tfa}
    set f [file join [pwd] tfa a ]
    file mkdir $f
    set result [file isdir $f ]
    file delete $f [file join [pwd] tfa]
    set result
} {1}

#
# Functionality tests for TclFileRenameCmd()
#

test fCmd-18.1 {TclFileRenameCmd: rename (first form) in the same directory} \
	{notRoot} {
    catch {file delete -force -- tfad}
    file mkdir tfad/dir
    cd tfad/dir
    set s [createfile foo ]
    file rename  foo bar
    file rename bar ./foo
    file rename ./foo bar
................................................................................
    file rename foo [file join [pwd] bar]
    set result [expr [checkcontent bar $s] && ![file exists foo]]
    cd ../..
    file delete -force tfad
    set result
} {1}

test fCmd-18.2 {TclFileRenameCmd: single dir to nonexistant} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    file mkdir tfa1
    file rename tfa1 tfa2
    set result [expr [file exists tfa2] && ![file exists tfa1]]
    file delete tfa2
    set result
} {1}

test fCmd-18.3 {TclFileRenameCmd: mixed dirs and files into directory} {notRoot} {
    catch {file delete -force -- tfa1 tfad1 tfad2}
    set s [createfile tfa1 ]
    file mkdir tfad1 tfad2
    file rename tfa1 tfad1 tfad2
    set r1 [checkcontent  tfad2/tfa1 $s]
    set r2 [file isdir tfad2/tfad1]
    set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfad1]]
    file delete tfad2/tfa1
    file delete -force tfad2
    set result
} {1}

test fCmd-18.4 {TclFileRenameCmd: attempt to replace non-dir with dir} {notRoot} {
    catch {file delete -force -- tfa tfad}
    set s [createfile tfa ]
    file mkdir tfad
    set r1 [catch {file rename tfad tfa}]
    set r2 [checkcontent tfa $s]
    set r3 [file isdir tfad]
    set result [expr $r1 && $r2 && $r3 ]
    file delete tfa tfad
    set result
} {1}

test fCmd-18.5 {TclFileRenameCmd: attempt to replace dir with non-dir} {notRoot} {
    catch {file delete -force -- tfa tfad}
    set s [createfile tfa ]
    file mkdir tfad/tfa
    set r1 [catch {file rename tfa tfad}]
    set r2 [checkcontent tfa $s]
    set r3 [file isdir tfad/tfa]
    set result [expr $r1 && $r2 && $r3 ]
................................................................................
    file delete -force  tfa tfad
    set result
} {1}

#
# On Windows there is no easy way to determine if two files are the same
#
test fCmd-18.6 {TclFileRenameCmd: rename a file to itself} {macOrUnix notRoot} {
    catch {file delete -force -- tfa}
    set s [createfile tfa]
    set r1 [catch {file rename tfa tfa}]
    set result [expr $r1 && [checkcontent tfa $s]]
    file delete tfa
    set result
} {1}

test fCmd-18.7 {TclFileRenameCmd: rename dir on top of another empty dir w/o -force} \
	{notRoot} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa tfad/tfa
    set r1 [catch {file rename tfa tfad}]
    set result [expr $r1 && [file isdir tfa]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-18.8 {TclFileRenameCmd: rename dir on top of another empty dir w/ -force} \
	{notRoot} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa tfad/tfa
    file rename -force tfa tfad
    set result [expr ![file isdir tfa]]
    file delete -force tfad
    set result
} {1}

test fCmd-18.9 {TclFileRenameCmd: rename dir on top of a non-empty dir w/o -force} \
	{notRoot} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa tfad/tfa/file
    set r1 [catch {file rename tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -force} \
	{notRoot} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa tfad/tfa/file
    set r1 [catch {file rename -force tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-18.11 {TclFileRenameCmd: rename a non-existant file} {notRoot} {
    catch {file delete -force -- tfa1}
    set r1 [catch {file rename tfa1 tfa2}]
    set result [expr $r1 && ![file exists tfa1] && ![file exists tfa2]]
} {1}

test fCmd-18.12 {TclFileRenameCmd : rename a symbolic link to file} \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
	
    set s [createfile tfa1]
    exec ln -s tfa1 tfa2
    file rename tfa2 tfa3
    set t [file type tfa3]
    set result [expr { $t == "link" }]
    file delete tfa1 tfa3
    set result
} {1}

test fCmd-18.13 {TclFileRenameCmd : rename a symbolic link to dir} \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
	
    file mkdir tfa1
    exec ln -s tfa1 tfa2
    file rename tfa2 tfa3
    set t [file type tfa3]
    set result [expr { $t == "link" }]
    file delete tfa1 tfa3
    set result
} {1}

test fCmd-18.14 {TclFileRenameCmd : rename a path with sym link} \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
	
    file mkdir tfa1/a/b/c/d
    file mkdir tfa2
    set f [file join [pwd] tfa1/a/b] 
    set f2 [file join [pwd] {tfa2/b alias}]
    exec ln -s $f $f2
................................................................................
    set r1 [file isdir tfa3]
    set r2 [file exists tfa1/a/b/c]
    set result [expr $r1 && !$r2]
    file delete -force tfa1 tfa2 tfa3
    set result
} {1}

test fCmd-18.15 {TclFileRenameCmd : rename a file to a symlink dir} \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfalink}
	
    file mkdir tfa1
    set s [createfile tfa2]
    exec ln -s tfa1 tfalink

    file rename tfa2 tfalink
    set result [checkcontent tfa1/tfa2 $s ]
    file delete -force tfa1 tfalink
    set result
} {1}

test fCmd-18.16 {TclFileRenameCmd: rename a dangling symlink} {unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfalink}
	
    file mkdir tfa1
    exec ln -s tfa1 tfalink
    file delete tfa1 
    file rename tfalink tfa2
    set result [expr [string compare [file type tfa2] "link"] == 0]
................................................................................
    set result
} {1}


#
# Coverage tests for TclUnixRmdir
#
test fCmd-19.1 { remove empty directory } {notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file delete tfa
    file exists tfa
} {0}

test fCmd-19.2 { rmdir error besides EEXIST} {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/a
    exec chmod 555 tfa
    set result [catch {file delete tfa/a}]
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}

test fCmd-19.3 { recursive remove } {notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/a
    file delete -force tfa
    file exists tfa
} {0}

................................................................................
#
#

#
# Coverage tests for TraverseUnixTree(), called from TclDeleteFilesCmd
#

test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory } \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/a
    exec chmod 000 tfa/a
    set result [catch {file delete -force tfa}]
    exec chmod 777 tfa/a
    file delete -force tfa
................................................................................
    set result
} {1}


#
# Feature testing for TclCopyFilesCmd
# 
test fCmd-21.1 {copy : single file to nonexistant } {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    set s [createfile tfa1]
    file copy tfa1 tfa2
    set result [expr [checkcontent tfa2 $s] && [checkcontent tfa1 $s]]
    file delete tfa1 tfa2
    set result
} {1}

test fCmd-21.2 {copy : single dir to nonexistant } {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    file mkdir tfa1
    file copy tfa1 tfa2
    set result [expr [file isdir tfa2] && [file isdir tfa1]]
    file delete tfa1 tfa2
    set result
} {1}

test fCmd-21.3 {copy : single file into directory  } {notRoot} {
    catch {file delete -force -- tfa1 tfad}
    set s [createfile tfa1]
    file mkdir tfad
    file copy tfa1 tfad
    set result [expr [checkcontent tfad/tfa1 $s] && [checkcontent tfa1 $s]]
    file delete -force tfa1 tfad
    set result
} {1}

test fCmd-21.4 {copy : more than one source and target is not a directory} \
	{notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
    createfile tfa1 
    createfile tfa2 
    createfile tfa3 
    set result [catch {file copy tfa1 tfa2 tfa3}]
    file delete tfa1 tfa2 tfa3
    set result
} {1}

test fCmd-21.5 {copy : multiple files into directory  } {notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfad}
    set s1 [createfile tfa1 ]
    set s2 [createfile tfa2 ]
    file mkdir tfad
    file copy tfa1 tfa2 tfad
    set r1 [checkcontent tfad/tfa1 $s1]
    set r2 [checkcontent tfad/tfa2 $s2]
................................................................................
    set r3 [checkcontent tfa1 $s1]
    set r4 [checkcontent tfa2 $s2]
    set result [expr $r1 && $r2 && $r3 && $r4]
    file delete -force tfa1 tfa2 tfad
    set result
} {1}

test fCmd-21.6 {copy: mixed dirs and files into directory} \
	{notRoot notFileSharing} {
    catch {file delete -force -- tfa1 tfad1 tfad2}
    set s [createfile tfa1 ]
    file mkdir tfad1 tfad2
    file copy tfa1 tfad1 tfad2
    set r1 [checkcontent [file join tfad2 tfa1] $s]
    set r2 [file isdir [file join tfad2 tfad1]]
    set r3 [checkcontent tfa1 $s]
    set result [expr $r1 && $r2 && $r3 && [file isdir tfad1]]
    file delete -force tfa1 tfad1 tfad2
    set result
} {1}

test fCmd-21.7 {TclCopyFilesCmd: copy a dangling link} {unixOnly notRoot} {
    file mkdir tfad1
    exec ln -s tfad1 tfalink
    file delete tfad1
    file copy tfalink tfalink2
    set result [string match [file type tfalink2] link]
    file delete tfalink tfalink2 
    set result
} {1}

test fCmd-21.8 {TclCopyFilesCmd : copy a link } {unixOnly notRoot} {
    file mkdir tfad1
    exec ln -s tfad1 tfalink
    file copy tfalink tfalink2
    set r1 [file type tfalink]
    set r2 [file type tfalink2]
    set r3 [file isdir tfad1]
    set result [expr {("$r1" == "link" ) && ("$r2" == "link" ) && $r3}]
    file delete tfad1 tfalink tfalink2
    set result
} {1}

test fCmd-21.9 {TclCopyFilesCmd: copy dir with a link in it} {unixOnly notRoot} {
    file mkdir tfad1
    exec ln -s "[pwd]/tfad1" tfad1/tfalink
    file copy tfad1 tfad2
    set result [string match [file type tfad2/tfalink] link]
    file delete -force tfad1 tfad2
    set result
} {1}

test fCmd-21.10 {TclFileCopyCmd: copy dir on top of another empty dir w/o -force} \
	{notRoot} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa [file join tfad tfa]
    set r1 [catch {file copy tfa tfad}]
    set result [expr $r1 && [file isdir tfa]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-21.11 {TclFileCopyCmd: copy dir on top of a dir w/o -force} {notRoot} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa [file join tfad tfa file]
    set r1 [catch {file copy tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]]
    file delete -force tfa tfad
    set result
} {1}

test fCmd-21.12 {TclFileCopyCmd: copy dir on top of a non-empty dir w/ -force} \
	{notRoot} {
    catch {file delete -force -- tfa tfad}
    file mkdir tfa [file join tfad tfa file]
    set r1 [catch {file copy -force tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]]
    file delete -force tfa tfad
    set result
} {1}
   
#
# Coverage testing for TclpRenameFile
#
test fCmd-22.1 {TclpRenameFile: rename and overwrite in a single dir} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    set s [createfile tfa1]
    set s2 [createfile tfa2 q]
	
    set r1 [catch {rename tfa1 tfa2}]
    file rename -force tfa1 tfa2
    set result [expr $r1 && [checkcontent tfa2 $s]]
    file delete [glob tfa1 tfa2]
    set result
} {1}

test fCmd-22.2 {TclpRenameFile: attempt to overwrite itself} {macOrUnix notRoot} {
    catch {file delete -force -- tfa1}
    set s [createfile tfa1]	
    file rename -force tfa1 tfa1
    set result [checkcontent tfa1 $s]
    file delete tfa1 
    set result
} {1}

test fCmd-22.3 { TclpRenameFile : rename dir to existing dir } {notRoot} {
    catch {file delete -force -- d1 tfad}
    file mkdir d1 [file join tfad d1]
    set r1 [catch {file rename d1 tfad}]
    set result [expr $r1 && [file isdir d1] && [file isdir [file join tfad d1]]]
    file delete -force d1 tfad
    set result
} {1}

test fCmd-22.4 {TclpRenameFile: rename dir to dir several levels deep} {notRoot} {
    catch {file delete -force -- d1 tfad}
    file mkdir d1 [file join tfad a b c]
    file rename d1 [file join tfad a b c d1]
    set result [expr ![file isdir d1] && [file isdir [file join tfad a b c d1]]]
    file delete -force [glob d1 tfad]
    set result
} {1}


#
# TclMacCopyFile needs to be redone.
#
test fCmd-22.5 {TclMacCopyFile: copy and overwrite in a single dir} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    set s [createfile tfa1]
    set s2 [createfile tfa2 q]

    set r1 [catch {file copy tfa1 tfa2}]
    file copy -force tfa1 tfa2
    set result [expr $r1 && [checkcontent tfa2 $s] && [checkcontent tfa1 $s]]
................................................................................
#

#
# TclMacRmdir
# Error cases are not covered.
#

test fCmd-23.1 {TclMacRmdir: trying to remove a nonempty directory} {notRoot} {
    catch {file delete -force -- tfad}
	
    file mkdir [file join tfad dir]
	
    set result [catch {file delete tfad}]
    file delete -force tfad 
    set result
} {1}

#
# TclMacDeleteFile	
# Error cases are not covered.
#
test fCmd-24.1 {TclMacDeleteFile: deleting a normal file} {notRoot} {
    catch {file delete -force -- tfa1}
	
    createfile tfa1
    file delete tfa1
    file exists tfa1
} {0}

#
# TclMacCopyDirectory
# Error cases are not covered.
#
test fCmd-25.1 { TclMacCopyDirectory : copying a normal directory} \
	{notRoot notFileSharing} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir [file join tfad1 a b c]
    file copy tfad1 tfad2
    set result [expr [file isdir [file join tfad1 a b c]] && [file isdir [file join tfad2 a b c]]]
    file delete -force tfad1 tfad2
    set result
} {1}

test fCmd-25.2 { TclMacCopyDirectory : copying a short path normal directory} \
	{notRoot notFileSharing} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    file copy tfad1 tfad2
    set result [expr [file isdir tfad1] && [file isdir tfad2]]
    file delete tfad1 tfad2
    set result
} {1}

test fCmd-25.3 { TclMacCopyDirectory : copying dirs between different dirs} \
	{notRoot notFileSharing} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir [file join tfad1 x y z]
    file mkdir [file join tfad2 dir]
    file copy tfad1 [file join tfad2 dir]
    set result [expr [file isdir [file join tfad1 x y z]] && [file isdir [file join tfad2 dir tfad1 x y z]]]
    file delete -force tfad1 tfad2
................................................................................
    set result
} {1}

#
# Functionality tests for TclDeleteFilesCmd
#

test fCmd-26.1 { TclDeleteFilesCmd : delete symlink} {unixOnly notRoot} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    exec ln -s tfad1 tfalink
    file delete tfalink

    set r1 [file isdir tfad1]
................................................................................
    set r2 [file exists tfalink]
    
    set result [expr $r1 && !$r2]
    file delete tfad1
    set result
} {1}

test fCmd-26.2 { TclDeleteFilesCmd : delete dir with symlink} {unixOnly notRoot} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    file mkdir tfad2
    exec ln -s tfad1 [file join tfad2 link]
    file delete -force tfad2

................................................................................
    set r2 [file exists tfad2]
    
    set result [expr $r1 && !$r2]
    file delete tfad1
    set result
} {1}

test fCmd-26.3 { TclDeleteFilesCmd : delete dangling symlink} {unixOnly notRoot} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    exec ln -s tfad1 tfad2
    file delete tfad1
    file delete tfad2

................................................................................
test fCmd-27.4 {TclFileAttrsCmd - getting one option} {
    catch {file delete -force -- foo.tmp}
    createfile foo.tmp
    set attrs [file attributes foo.tmp]
    list [catch {eval file attributes foo.tmp [lindex $attrs 0]}] [file delete -force -- foo.tmp]
} {0 {}}

# Find a group that exists on this Unix system, or else skip tests that
# require Unix groups.
if {$tcl_platform(platform) == "unix"} {
    set ::tcltest::testConfig(foundGroup) 0
    catch {
	set groupList [exec groups]
	set group [lindex $groupList 0]
	set ::tcltest::testConfig(foundGroup) 1
    }
} else {
    set ::tcltest::testConfig(foundGroup) 1
}

test fCmd-27.5 {TclFileAttrsCmd - setting one option} {foundGroup} {
    catch {file delete -force -- foo.tmp}
    createfile foo.tmp
    set attrs [file attributes foo.tmp]
    list [catch {eval file attributes foo.tmp [lrange $attrs 0 1]} msg] $msg [file delete -force -- foo.tmp]
} {0 {} {}}
test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} {foundGroup} {
    catch {file delete -force -- foo.tmp}
    createfile foo.tmp
    set attrs [file attributes foo.tmp]
    list [catch {eval file attributes foo.tmp [lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp]
} {0 {} {}}

# cleanup
cleanup
::tcltest::cleanupTests
return











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
....
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
....
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
....
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
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
....
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
....
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323

1324
1325
1326
1327

1328
1329

1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355

1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
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
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420

1421
1422
1423
1424
1425
1426
1427
1428
1429
1430




1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445

1446
1447
1448
1449
1450
1451










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

#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: fileName.test,v 1.1.2.3 1999/03/11 18:49:37 hershey Exp $

if {[string compare test [info procs test]] == 1} then {source defs}



if {[info commands testsetplatform] == {}} {
    puts "This application hasn't been compiled with the \"testsetplatform\""
    puts "command, so I can't test the filename conversion procedures."
    return 
} 

................................................................................
close [open globTest/x1.c w]
close [open globTest/y1.c w]
close [open globTest/z1.c w]
close [open "globTest/weird name.c" w]
close [open globTest/a1/b1/x2.c w]
close [open globTest/a1/b2/y2.c w]

# Cannot create a file with the following names under Win32s.  We have to
# skip the tests that are checking the difference between a "." or "," in
# the file name vs. a "." or "," in the glob pattern.

catch {close [open globTest/.1 w]}
catch {close [open globTest/x,z1.c w]}

test filename-11.14 {Tcl_GlobCmd} {
    list [catch {glob ~/globTest} msg] $msg
} [list 0 [list [file join $env(HOME) globTest]]]
test filename-11.15 {Tcl_GlobCmd} {
................................................................................
} "0 $globPreResult$x1"
test filename-13.7 {globbing with brace substitution} {
    list [catch {glob globTest/\{x\}1.c} msg] $msg
} "0 $globPreResult$x1"
test filename-13.8 {globbing with brace substitution} {
    list [catch {glob globTest/\{x\{\}\}1.c} msg] $msg
} "0 $globPreResult$x1"
test filename-13.9 {globbing with brace substitution} {!win32s} {
    list [lsort [catch {glob globTest/\{x,y\}1.c} msg]] $msg
} [list 0 [list $globPreResult$x1 $globPreResult$y1]]
test filename-13.10 {globbing with brace substitution} {!win32s} {
    list [lsort [catch {glob globTest/\{x,,y\}1.c} msg]] $msg
} [list 0 [list $globPreResult$x1 $globPreResult$y1]]
test filename-13.11 {globbing with brace substitution} {unixOrPc && !win32s} {
    list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg
} {0 {globTest/x1.c globTest/x,z1.c globTest/z1.c}}
test filename-13.12 {globbing with brace substitution} {macOnly} {
    list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg
} {0 {:globTest:x1.c :globTest:x,z1.c :globTest:z1.c}}
test filename-13.13 {globbing with brace substitution} {
    lsort [glob globTest/{a,b,x,y}1.c]
................................................................................
test filename-13.21 {globbing with brace substitution} {macOnly} {
    lsort [glob globTest/{a,x}1/*/{x,y}*]
} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c}
test filename-13.22 {globbing with brace substitution} {
    list [catch {glob globTest/\{a,x\}1/*/\{} msg] $msg
} {1 {unmatched open-brace in file name}}

test filename-14.1 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
    lsort [glob g*/*.c]
} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.1 {asterisks, question marks, and brackets} {win32s} {
    lsort [glob g*/*.c]
} {globtest/weirdn~1.c globtest/x1.c globtest/y1.c globtest/z1.c}
test filename-14.2 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob g*/*.c]
} {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}
test filename-14.3 {asterisks, question marks, and brackets} {unixOrPc} {
    lsort [glob globTest/?1.c]
} {globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.4 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob globTest/?1.c]
} {:globTest:x1.c :globTest:y1.c :globTest:z1.c}
test filename-14.5 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
    lsort [glob */*/*/*.c]
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
test filename-14.5 {asterisks, question marks, and brackets} {win32s} {
    lsort [glob */*/*/*.c]
} {globtest/a1/b1/x2.c globtest/a1/b2/y2.c}
test filename-14.6 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob */*/*/*.c]
} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c}
test filename-14.7 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
    lsort [glob globTest/*]
} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.7 {asterisks, question marks, and brackets} {win32s} {
    lsort [glob globTest/*]
} {globTest/a1 globTest/a2 globTest/a3 globTest/weirdn~1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.8 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob globTest/*]
} {:globTest:.1 :globTest:a1 :globTest:a2 :globTest:a3 {:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}
test filename-14.9 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
    lsort [glob globTest/.*]
} {globTest/. globTest/.. globTest/.1}
test filename-14.9 {asterisks, question marks, and brackets} {win32s} {
    lsort [glob globTest/.*]
} {globTest/. globTest/..}
test filename-14.10 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob globTest/.*]
} {:globTest:.1}
test filename-14.11 {asterisks, question marks, and brackets} {unixOrPc} {
    lsort [glob globTest/*/*]
} {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3}
test filename-14.12 {asterisks, question marks, and brackets} {macOnly} {
................................................................................
    global env
    set temp $env(HOME)
    set env(HOME) [file join $env(HOME) globTest]
    set result [list [catch {glob ~/z*} msg] $msg]
    set env(HOME) $temp
    set result
} [list 0 [list [file join $env(HOME) globTest z1.c]]]
test filename-14.18 {asterisks, question marks, and brackets} {unixOrPc && !win32s} {
    list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg
} {0 {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}}
test filename-14.18 {asterisks, question marks, and brackets} {win32s} {
    list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg
} {0 {globTest/weirdn~1.c globTest/x1.c globTest/y1.c globTest/z1.c}}
test filename-14.19 {asterisks, question marks, and brackets} {macOnly} {
    list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg
} {0 {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}}
test filename-14.20 {asterisks, question marks, and brackets} {
    list [catch {glob -nocomplain goo/*} msg] $msg
} {0 {}}
test filename-14.21 {asterisks, question marks, and brackets} {
................................................................................
    glob /
} /
test filename-14.24 {slash globbing} {pcOnly} {
    glob {\\}
} /

# The following tests are only valid for Unix systems.

if {$tcl_platform(platform) == "unix"} {
    # On some systems, like AFS, "000" protection doesn't prevent
    # access by owner, so the following test is not portable.

    exec chmod 000 globTest/a1
    test filename-15.1 {unix specific globbing} {nonPortable} {
	string tolower [list [catch {glob globTest/a1/*} msg]  $msg $errorCode]
    } {1 {couldn't read directory "globtest/a1": permission denied} {posix eacces {permission denied}}}
    test filename-15.2 {unix specific no complain: no errors} {nonPortable} {
	glob -nocomplain globTest/a1/*
    } {}
    test filename-15.3 {unix specific no complain: no errors, good result} {nonPortable knownBug} {

	# test fails because if an error occur , the interp's result
	# is reset...
	glob -nocomplain globTest/a2 globTest/a1/* globTest/a3
    } {globTest/a2 globTest/a3}

    exec chmod 755 globTest/a1
    test filename-15.4 {unix specific no complain: no errors, good result} {nonPortable knownBug} {

	# test fails because if an error occur , the interp's result
	# is reset... (or you don't run at sunscript where the
	# outser and demailly's users exists
	glob -nocomplain ~ouster ~foo ~demailly
    } {/home/ouster /home/demailly}
    test filename-15.5 {unix specific globbing} {nonPortable} {
	glob ~ouster/.csh*
    } "/home/ouster/.cshrc"
    close [open globTest/odd\\\[\]*?\{\}name w]
    test filename-15.6 {unix specific globbing} {
	global env
	set temp $env(HOME)
	set env(HOME) $env(HOME)/globTest/odd\\\[\]*?\{\}name
	set result [list [catch {glob ~} msg] $msg]
	set env(HOME) $temp
	set result
    } [list 0 [list [glob ~]/globTest/odd\\\[\]*?\{\}name]]
    exec rm -f globTest/odd\\\[\]*?\{\}name
}

# The following tests are only valid for Windows systems.

if {$tcl_platform(platform) == "windows"} {
    set temp [pwd]
    cd c:/
    catch {

	removeDirectory globTest
	makeDirectory globTest
	close [open globTest/x1.BAT w]
	close [open globTest/y1.Bat w]
	close [open globTest/z1.bat w]
    }
    
    test filename-16.1 {windows specific globbing} {!win32s} {
	lsort [glob globTest/*.bat]
    } {globTest/x1.BAT globTest/y1.Bat globTest/z1.bat}
    test filename-16.1 {windows specific globbing} {win32s} {
	lsort [glob globTest/*.bat]
    } {globTest/x1.bat globTest/y1.bat globTest/z1.bat}
    test filename-16.2 {windows specific globbing} {
	glob c:
    } c:
    test filename-16.3 {windows specific globbing} {
	glob c:\\\\
	} c:/
    test filename-16.4 {windows specific globbing} {
	glob c:/
    } c:/
    test filename-16.5 {windows specific globbing} {!win32s} {
	glob c:*Test
    } c:globTest
    test filename-16.5 {windows specific globbing} {win32s} {
	glob c:*Test
    } c:globtest
    test filename-16.6 {windows specific globbing} {!win32s} {
	glob c:\\\\*Test
    } c:/globTest
    test filename-16.6 {windows specific globbing} {win32s} {
	glob c:\\\\*Test
    } c:/globtest
    test filename-16.7 {windows specific globbing} {!win32s} {
	glob c:/*Test
    } c:/globTest
    test filename-16.7 {windows specific globbing} {win32s} {
	glob c:/*Test
    } c:/globtest
    test filename-16.8 {windows specific globbing} {!win32s} {
	lsort [glob c:globTest/*.bat]
    } {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat}
    test filename-16.8 {windows specific globbing} {win32s} {
	lsort [glob c:globTest/*.bat]
    } {c:globTest/x1.bat c:globTest/y1.bat c:globTest/z1.bat}
    test filename-16.9 {windows specific globbing} {!win32s} {
	lsort [glob c:/globTest/*.bat]
    } {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat}
    test filename-16.9 {windows specific globbing} {win32s} {
	lsort [glob c:/globTest/*.bat]
    } {c:/globTest/x1.bat c:/globTest/y1.bat c:/globTest/z1.bat}
    test filename-16.10 {windows specific globbing} {!win32s} {
	lsort [glob c:globTest\\\\*.bat]
    } {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat}
    test filename-16.10 {windows specific globbing} {win32s} {
	lsort [glob c:globTest\\\\*.bat]
    } {c:globTest/x1.bat c:globTest/y1.bat c:globTest/z1.bat}
    test filename-16.11 {windows specific globbing} {!win32s} {
	lsort [glob c:\\\\globTest\\\\*.bat]
    } {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat}
    test filename-16.11 {windows specific globbing} {win32s} {
	lsort [glob c:\\\\globTest\\\\*.bat]
    } {c:/globTest/x1.bat c:/globTest/y1.bat c:/globTest/z1.bat}


    removeDirectory globTest

    if {($::test::testConfig(nonPortable) != 0) && [catch {cd //gaspode/d}] == 0} {
	removeDirectory globTest
	makeDirectory globTest

	close [open globTest/x1.BAT w]
	close [open globTest/y1.Bat w]
	close [open globTest/z1.bat w]





	test filename-16.12 {windows specific globbing} {
	    glob //gaspode/d/*Test
	} //gaspode/d/globTest
	test filename-16.13 {windows specific globbing} {
	    glob {\\\\gaspode\\d\\*Test}
	} //gaspode/d/globTest

	removeDirectory globTest
    }	    

    cd $temp
}

# cleanup
removeDirectory globTest

set env(HOME) $oldhome
testsetplatform $platform
catch {unset oldhome platform temp result}
::test::cleanupTests
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
....
1102
1103
1104
1105
1106
1107
1108




1109
1110
1111
1112
1113
1114
1115
....
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
....
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



1243
1244
1245
1246
1247
1248
1249
....
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274



1275
1276
1277
1278
1279
1280
1281
....
1288
1289
1290
1291
1292
1293
1294


1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335


1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349



1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361



1362
1363
1364



1365
1366
1367



1368
1369
1370



1371
1372
1373



1374
1375
1376



1377
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
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
# 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.
#
# RCS: @(#) $Id: fileName.test,v 1.1.2.4 1999/03/23 20:06:22 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[info commands testsetplatform] == {}} {
    puts "This application hasn't been compiled with the \"testsetplatform\""
    puts "command, so I can't test the filename conversion procedures."
    return 
} 

................................................................................
close [open globTest/x1.c w]
close [open globTest/y1.c w]
close [open globTest/z1.c w]
close [open "globTest/weird name.c" w]
close [open globTest/a1/b1/x2.c w]
close [open globTest/a1/b2/y2.c w]





catch {close [open globTest/.1 w]}
catch {close [open globTest/x,z1.c w]}

test filename-11.14 {Tcl_GlobCmd} {
    list [catch {glob ~/globTest} msg] $msg
} [list 0 [list [file join $env(HOME) globTest]]]
test filename-11.15 {Tcl_GlobCmd} {
................................................................................
} "0 $globPreResult$x1"
test filename-13.7 {globbing with brace substitution} {
    list [catch {glob globTest/\{x\}1.c} msg] $msg
} "0 $globPreResult$x1"
test filename-13.8 {globbing with brace substitution} {
    list [catch {glob globTest/\{x\{\}\}1.c} msg] $msg
} "0 $globPreResult$x1"
test filename-13.9 {globbing with brace substitution} {
    list [lsort [catch {glob globTest/\{x,y\}1.c} msg]] $msg
} [list 0 [list $globPreResult$x1 $globPreResult$y1]]
test filename-13.10 {globbing with brace substitution} {
    list [lsort [catch {glob globTest/\{x,,y\}1.c} msg]] $msg
} [list 0 [list $globPreResult$x1 $globPreResult$y1]]
test filename-13.11 {globbing with brace substitution} {unixOrPc} {
    list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg
} {0 {globTest/x1.c globTest/x,z1.c globTest/z1.c}}
test filename-13.12 {globbing with brace substitution} {macOnly} {
    list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg
} {0 {:globTest:x1.c :globTest:x,z1.c :globTest:z1.c}}
test filename-13.13 {globbing with brace substitution} {
    lsort [glob globTest/{a,b,x,y}1.c]
................................................................................
test filename-13.21 {globbing with brace substitution} {macOnly} {
    lsort [glob globTest/{a,x}1/*/{x,y}*]
} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c}
test filename-13.22 {globbing with brace substitution} {
    list [catch {glob globTest/\{a,x\}1/*/\{} msg] $msg
} {1 {unmatched open-brace in file name}}

test filename-14.1 {asterisks, question marks, and brackets} {unixOrPc} {
    lsort [glob g*/*.c]
} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}



test filename-14.2 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob g*/*.c]
} {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}
test filename-14.3 {asterisks, question marks, and brackets} {unixOrPc} {
    lsort [glob globTest/?1.c]
} {globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.4 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob globTest/?1.c]
} {:globTest:x1.c :globTest:y1.c :globTest:z1.c}
test filename-14.5 {asterisks, question marks, and brackets} {unixOrPc} {
    lsort [glob */*/*/*.c]
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}



test filename-14.6 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob */*/*/*.c]
} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c}
test filename-14.7 {asterisks, question marks, and brackets} {unixOrPc} {
    lsort [glob globTest/*]
} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}



test filename-14.8 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob globTest/*]
} {:globTest:.1 :globTest:a1 :globTest:a2 :globTest:a3 {:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}
test filename-14.9 {asterisks, question marks, and brackets} {unixOrPc} {
    lsort [glob globTest/.*]
} {globTest/. globTest/.. globTest/.1}



test filename-14.10 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob globTest/.*]
} {:globTest:.1}
test filename-14.11 {asterisks, question marks, and brackets} {unixOrPc} {
    lsort [glob globTest/*/*]
} {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3}
test filename-14.12 {asterisks, question marks, and brackets} {macOnly} {
................................................................................
    global env
    set temp $env(HOME)
    set env(HOME) [file join $env(HOME) globTest]
    set result [list [catch {glob ~/z*} msg] $msg]
    set env(HOME) $temp
    set result
} [list 0 [list [file join $env(HOME) globTest z1.c]]]
test filename-14.18 {asterisks, question marks, and brackets} {unixOrPc} {
    list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg
} {0 {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}}



test filename-14.19 {asterisks, question marks, and brackets} {macOnly} {
    list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg
} {0 {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}}
test filename-14.20 {asterisks, question marks, and brackets} {
    list [catch {glob -nocomplain goo/*} msg] $msg
} {0 {}}
test filename-14.21 {asterisks, question marks, and brackets} {
................................................................................
    glob /
} /
test filename-14.24 {slash globbing} {pcOnly} {
    glob {\\}
} /

# The following tests are only valid for Unix systems.


# On some systems, like AFS, "000" protection doesn't prevent
# access by owner, so the following test is not portable.

catch {exec chmod 000 globTest/a1}
test filename-15.1 {unix specific globbing} {unixOnly nonPortable} {
    string tolower [list [catch {glob globTest/a1/*} msg]  $msg $errorCode]
} {1 {couldn't read directory "globtest/a1": permission denied} {posix eacces {permission denied}}}
test filename-15.2 {unix specific no complain: no errors} {unixOnly nonPortable} {
    glob -nocomplain globTest/a1/*
} {}
test filename-15.3 {unix specific no complain: no errors, good result} \
	{unixOnly nonPortable knownBug} {
    # test fails because if an error occur , the interp's result
    # is reset...
    glob -nocomplain globTest/a2 globTest/a1/* globTest/a3
} {globTest/a2 globTest/a3}

catch {exec chmod 755 globTest/a1}
test filename-15.4 {unix specific no complain: no errors, good result} \
	{unixOnly nonPortable knownBug} {
    # test fails because if an error occurs, the interp's result
    # is reset... or you don't run at scriptics where the
    # outser and welch users exists
    glob -nocomplain ~ouster ~foo ~welch
} {/home/ouster /home/welch}
test filename-15.5 {unix specific globbing} {unixOnly nonPortable} {
    glob ~ouster/.csh*
} "/home/ouster/.cshrc"
catch {close [open globTest/odd\\\[\]*?\{\}name w]}
test filename-15.6 {unix specific globbing} {unixOnly} {
    global env
    set temp $env(HOME)
    set env(HOME) $env(HOME)/globTest/odd\\\[\]*?\{\}name
    set result [list [catch {glob ~} msg] $msg]
    set env(HOME) $temp
    set result
} [list 0 [list [glob ~]/globTest/odd\\\[\]*?\{\}name]]
catch {exec rm -f globTest/odd\\\[\]*?\{\}name}


# The following tests are only valid for Windows systems.


set temp [pwd]
catch {cd c:/}
catch {
    cd c:/
    removeDirectory globTest
    makeDirectory globTest
    close [open globTest/x1.BAT w]
    close [open globTest/y1.Bat w]
    close [open globTest/z1.bat w]
}

test filename-16.1 {windows specific globbing} {pcOnly} {
    lsort [glob globTest/*.bat]
} {globTest/x1.BAT globTest/y1.Bat globTest/z1.bat}



test filename-16.2 {windows specific globbing} {pcOnly} {
    glob c:
} c:
test filename-16.3 {windows specific globbing} {pcOnly} {
    glob c:\\\\
} c:/
test filename-16.4 {windows specific globbing} {pcOnly} {
    glob c:/
} c:/
test filename-16.5 {windows specific globbing} {pcOnly} {
    glob c:*Test
} c:globTest



test filename-16.6 {windows specific globbing} {pcOnly} {
    glob c:\\\\*Test
} c:/globTest



test filename-16.7 {windows specific globbing} {pcOnly} {
    glob c:/*Test
} c:/globTest



test filename-16.8 {windows specific globbing} {pcOnly} {
    lsort [glob c:globTest/*.bat]
} {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat}



test filename-16.9 {windows specific globbing} {pcOnly} {
    lsort [glob c:/globTest/*.bat]
} {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat}



test filename-16.10 {windows specific globbing} {pcOnly} {
    lsort [glob c:globTest\\\\*.bat]
} {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat}



test filename-16.11 {windows specific globbing} {pcOnly} {
    lsort [glob c:\\\\globTest\\\\*.bat]
} {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat}




catch {
    removeDirectory globTest



    makeDirectory globTest

    close [open globTest/x1.BAT w]
    close [open globTest/y1.Bat w]
    close [open globTest/z1.bat w]
}

# the following tests rely upon the //gaspode/d directory's existence
set ::tcltest::testConfig(gaspodeExists) [expr {[catch {cd //gaspode/d}] == 0}]

test filename-16.12 {windows specific globbing} {pcOnly nonPortable gaspodeExists} {
    glob //gaspode/d/*Test
} //gaspode/d/globTest
test filename-16.13 {windows specific globbing} {pcOnly nonPortable gaspodeExists} {
    glob {\\\\gaspode\\d\\*Test}
} //gaspode/d/globTest







# cleanup
removeDirectory globTest
cd $temp
set env(HOME) $oldhome
testsetplatform $platform
catch {unset oldhome platform temp result}
::tcltest::cleanupTests
return











Changes to tests/for-old.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
62
63
64
65
66
67
68
69
70
71










#
# 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.
#
# RCS: @(#) $Id: for-old.test,v 1.1.2.3 1999/03/11 18:49:38 hershey Exp $

if {[string compare test [info procs test]] == 1} then {source defs}

# Check "for" and its use of continue and break.

catch {unset a i}
test for-old-1.1 {for tests} {
................................................................................
    for {set i 1} {$i<6} {set i [expr $i+1]; if $i==4 break} {
	set a [concat $a $i]
    }
    set a
} {1 2 3}

# cleanup
::test::cleanupTests
return

















|







 







|


>
>
>
>
>
>
>
>
>
>
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
#
# 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.
#
# RCS: @(#) $Id: for-old.test,v 1.1.2.4 1999/03/23 20:06:23 hershey Exp $

if {[string compare test [info procs test]] == 1} then {source defs}

# Check "for" and its use of continue and break.

catch {unset a i}
test for-old-1.1 {for tests} {
................................................................................
    for {set i 1} {$i<6} {set i [expr $i+1]; if $i==4 break} {
	set a [concat $a $i]
    }
    set a
} {1 2 3}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/for.test.

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
710
711
712
713
714
715
716
717
718
719










# 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.
#
# RCS: @(#) $Id: for.test,v 1.1.2.3 1999/03/11 18:49:38 hershey Exp $

if {[string compare test [info procs test]] == 1} then {source defs}

# Basic "for" operation.

test for-1.1 {TclCompileForCmd: missing initial command} {
    list [catch {for} msg] $msg
................................................................................
test for-5.15 {for cmd with computed command names: for command result} {
    set z for
    set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}]
    set a
} {}

# cleanup
::test::cleanupTests
return

















|







 







|


>
>
>
>
>
>
>
>
>
>
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
# 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.
#
# RCS: @(#) $Id: for.test,v 1.1.2.4 1999/03/23 20:06:24 hershey Exp $

if {[string compare test [info procs test]] == 1} then {source defs}

# Basic "for" operation.

test for-1.1 {TclCompileForCmd: missing initial command} {
    list [catch {for} msg] $msg
................................................................................
test for-5.15 {for cmd with computed command names: for command result} {
    set z for
    set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}]
    set a
} {}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/foreach.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
207
208
209
210
211
212
213
214
215
216










#
# 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.
#
# RCS: @(#) $Id: foreach.test,v 1.1.2.3 1999/03/11 18:49:39 hershey Exp $

if {[string compare test [info procs test]] == 1} then {source defs}

catch {unset a}
catch {unset x}

# Basic "foreach" operation.
................................................................................
    catch {break foo} msg
    set msg
} {wrong # args: should be "break"}

# cleanup
catch {unset a}
catch {unset x}
::test::cleanupTests
return

















|







 







|


>
>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
#
# 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.
#
# RCS: @(#) $Id: foreach.test,v 1.1.2.4 1999/03/23 20:06:25 hershey Exp $

if {[string compare test [info procs test]] == 1} then {source defs}

catch {unset a}
catch {unset x}

# Basic "foreach" operation.
................................................................................
    catch {break foo} msg
    set msg
} {wrong # args: should be "break"}

# cleanup
catch {unset a}
catch {unset x}
::tcltest::cleanupTests
return











Changes to tests/format.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
479
480
481
482
483
484
485
486
487
488










#
# 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.
#
# RCS: @(#) $Id: format.test,v 1.1.2.4 1999/03/11 18:49:39 hershey Exp $

if {[info commands test] != "test"} {
    source defs
}

# The following code is needed because some versions of SCO Unix have
# a round-off error in sprintf which would cause some of the tests to
................................................................................
}

# cleanup
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset d}
::test::cleanupTests
return

















|







 







|


>
>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
#
# 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.
#
# RCS: @(#) $Id: format.test,v 1.1.2.5 1999/03/23 20:06:25 hershey Exp $

if {[info commands test] != "test"} {
    source defs
}

# The following code is needed because some versions of SCO Unix have
# a round-off error in sprintf which would cause some of the tests to
................................................................................
}

# cleanup
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset d}
::tcltest::cleanupTests
return











Changes to tests/get.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
90
91
92
93
94
95
96
97
98
99










#
# 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.
#
# RCS: @(#) $Id: get.test,v 1.1.2.3 1999/03/11 18:49:40 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test get-1.1 {Tcl_GetInt procedure} {
    set x 44
    incr x { 	  22}
} {66}
................................................................................
    list [catch {format %g clip} msg] $msg
} {1 {expected floating-point number but got "clip"}}
test get-2.4 {Tcl_GetInt procedure} {nonPortable} {
    list [catch {format %g .000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001} msg] $msg $errorCode
} {1 {floating-point value too small to represent} {ARITH UNDERFLOW {floating-point value too small to represent}}}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
#
# 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.
#
# RCS: @(#) $Id: get.test,v 1.1.2.4 1999/03/23 20:06:26 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test get-1.1 {Tcl_GetInt procedure} {
    set x 44
    incr x { 	  22}
} {66}
................................................................................
    list [catch {format %g clip} msg] $msg
} {1 {expected floating-point number but got "clip"}}
test get-2.4 {Tcl_GetInt procedure} {nonPortable} {
    list [catch {format %g .000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001} msg] $msg $errorCode
} {1 {floating-point value too small to represent} {ARITH UNDERFLOW {floating-point value too small to represent}}}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/history.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
209
210
211
212
213
214
215
216
217
218










# 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.
#
# RCS: @(#) $Id: history.test,v 1.1.2.3 1999/03/11 18:49:40 hershey Exp $
  
if {[catch {history}]} {
    puts stdout "This version of Tcl was built without the history command;\n"
    puts stdout "history tests will be skipped.\n"
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set num [history nextid]
history keep 3
history add {set a 12345}
history add {set b [format {A test %s} string]}
................................................................................
test history-9.1 {miscellaneous} {catch {history gorp} msg} 1
test history-9.2 {miscellaneous} {
    catch {history gorp} msg
    set msg
} {bad option "gorp": must be add, change, clear, event, info, keep, nextid, or redo}

# cleanup
::test::cleanupTests
return

















|







|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
# 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.
#
# RCS: @(#) $Id: history.test,v 1.1.2.4 1999/03/23 20:06:26 hershey Exp $
  
if {[catch {history}]} {
    puts stdout "This version of Tcl was built without the history command;\n"
    puts stdout "history tests will be skipped.\n"
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set num [history nextid]
history keep 3
history add {set a 12345}
history add {set b [format {A test %s} string]}
................................................................................
test history-9.1 {miscellaneous} {catch {history gorp} msg} 1
test history-9.2 {miscellaneous} {
    catch {history gorp} msg
    set msg
} {bad option "gorp": must be add, change, clear, event, info, keep, nextid, or redo}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/http.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
294
295
296
297
298
299
300
301
302
303










# 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.
#
#
# RCS: @(#) $Id: http.test,v 1.1.2.4 1999/03/11 18:49:41 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {package require http 2.0}]} {
    if {[info exist http2]} {
	catch {puts "Cannot load http 2.0 package"}
	return
................................................................................
if {[info exists httpthread]} {
    testthread send -async $httpthread {
	testthread exit
    }
} else {
    close $listen
}
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
# 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.
#
#
# RCS: @(#) $Id: http.test,v 1.1.2.5 1999/03/23 20:06:27 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {package require http 2.0}]} {
    if {[info exist http2]} {
	catch {puts "Cannot load http 2.0 package"}
	return
................................................................................
if {[info exists httpthread]} {
    testthread send -async $httpthread {
	testthread exit
    }
} else {
    close $listen
}
::tcltest::cleanupTests
return











Changes to tests/httpold.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
416
417
418
419
420
421
422
423
424
425










# 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.
#
# RCS: @(#) $Id: httpold.test,v 1.1.2.3 1999/03/11 18:49:41 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {package require http 1.0}]} {
    if {[info exist httpold]} {
	catch {puts "Cannot load http 1.0 package"}
	return
................................................................................
<h2>GET http://$url</h2>
</body></html>"

# cleanup
unset url
unset port
close $listen
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
# 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.
#
# RCS: @(#) $Id: httpold.test,v 1.1.2.4 1999/03/23 20:06:27 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {package require http 1.0}]} {
    if {[info exist httpold]} {
	catch {puts "Cannot load http 1.0 package"}
	return
................................................................................
<h2>GET http://$url</h2>
</body></html>"

# cleanup
unset url
unset port
close $listen
::tcltest::cleanupTests
return











Changes to tests/if-old.test.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
155
156
157
158
159
160
161
162
163
164










# 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.
#
# RCS: @(#) $Id: if-old.test,v 1.1.2.3 1999/03/11 18:49:42 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test if-old-1.1 {taking proper branch} {
    set a {}
    if 0 {set a 1} else {set a 2}
    set a
................................................................................
    list [catch {if 0 then foo elseif 0 bar els} msg] $msg
} {1 {invalid command name "els"}}
test if-old-4.11 {error conditions} {
    list [catch {if 0 then foo elseif 0 bar else {[error "error in else clause"]}} msg] $msg
} {1 {error in else clause}}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
# 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.
#
# RCS: @(#) $Id: if-old.test,v 1.1.2.4 1999/03/23 20:06:28 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test if-old-1.1 {taking proper branch} {
    set a {}
    if 0 {set a 1} else {set a 2}
    set a
................................................................................
    list [catch {if 0 then foo elseif 0 bar els} msg] $msg
} {1 {invalid command name "els"}}
test if-old-4.11 {error conditions} {
    list [catch {if 0 then foo elseif 0 bar else {[error "error in else clause"]}} msg] $msg
} {1 {error in else clause}}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/if.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015










#
# 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.
#
# RCS: @(#) $Id: if.test,v 1.1.2.4 1999/03/11 18:49:42 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Basic "if" operation.

catch {unset a}
test if-1.1 {TclCompileIfCmd: missing if/elseif test} {
................................................................................
} def

test if-9.1 {if cmd with namespace qualifiers} {
    ::if {1} {set x 4}
} 4

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
#
# 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.
#
# RCS: @(#) $Id: if.test,v 1.1.2.5 1999/03/23 20:06:28 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Basic "if" operation.

catch {unset a}
test if-1.1 {TclCompileIfCmd: missing if/elseif test} {
................................................................................
} def

test if-9.1 {if cmd with namespace qualifiers} {
    ::if {1} {set x 4}
} 4

# cleanup
::tcltest::cleanupTests
return











Changes to tests/incr-old.test.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
..
86
87
88
89
90
91
92
93
94
95










# 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.
#
# RCS: @(#) $Id: incr-old.test,v 1.1.2.3 1999/03/11 18:49:43 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset x}

test incr-old-1.1 {basic incr operation} {
    set x 23
................................................................................
} {1 {expected integer but got "+"}}
test incr-old-2.10 {incr errors} {
    set x {20 x}
    list [catch {incr x 1} msg] $msg
} {1 {expected integer but got "20 x"}}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
..
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
# 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.
#
# RCS: @(#) $Id: incr-old.test,v 1.1.2.4 1999/03/23 20:06:29 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset x}

test incr-old-1.1 {basic incr operation} {
    set x 23
................................................................................
} {1 {expected integer but got "+"}}
test incr-old-2.10 {incr errors} {
    set x {20 x}
    list [catch {incr x 1} msg] $msg
} {1 {expected integer but got "20 x"}}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/incr.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
493
494
495
496
497
498
499
500
501
502










#
# 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.
#
# RCS: @(#) $Id: incr.test,v 1.1.2.3 1999/03/11 18:49:43 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Basic "incr" operation.

catch {unset x}
catch {unset i}
................................................................................
test incr-2.29 {incr command (not compiled): runtime error, bad variable value} {
    set z incr
    set x "  -  "
    list [catch {$z x 1} msg] $msg
} {1 {expected integer but got "  -  "}}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
#
# 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.
#
# RCS: @(#) $Id: incr.test,v 1.1.2.4 1999/03/23 20:06:29 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Basic "incr" operation.

catch {unset x}
catch {unset i}
................................................................................
test incr-2.29 {incr command (not compiled): runtime error, bad variable value} {
    set z incr
    set x "  -  "
    list [catch {$z x 1} msg] $msg
} {1 {expected integer but got "  -  "}}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/indexObj.test.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
..
65
66
67
68
69
70
71
72
73
74










#
# 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.
#
# RCS: @(#) $Id: indexObj.test,v 1.1.2.3 1999/03/11 18:49:44 hershey Exp $

if {[info commands testindexobj] == {}} {
    puts "This application hasn't been compiled with the \"testindexobj\""
    puts "command, so I can't test Tcl_GetIndexFromObj etc."
    return 
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test indexObj-1.1 {exact match} {
    testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} {
................................................................................
test indexObj-4.1 {free old internal representation} {
    set x {a b}
    lindex $x 1
    testindexobj 1 1 $x abc def {a b} zzz
} {2}

# cleanup
::test::cleanupTests
return

















|







|







 







|


>
>
>
>
>
>
>
>
>
>
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
..
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
#
# 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.
#
# RCS: @(#) $Id: indexObj.test,v 1.1.2.4 1999/03/23 20:06:30 hershey Exp $

if {[info commands testindexobj] == {}} {
    puts "This application hasn't been compiled with the \"testindexobj\""
    puts "command, so I can't test Tcl_GetIndexFromObj etc."
    return 
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test indexObj-1.1 {exact match} {
    testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} {
................................................................................
test indexObj-4.1 {free old internal representation} {
    set x {a b}
    lindex $x 1
    testindexobj 1 1 $x abc def {a b} zzz
} {2}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/info.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
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
...
499
500
501
502
503
504
505
506
507
508










# Copyright (c) 1991-1994 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: info.test,v 1.1.2.3 1999/03/11 18:49:45 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.

catch {namespace delete test_ns_info1 test_ns_info2}
................................................................................
    namespace eval test_ns_info2 {
        namespace import ::test_ns_info1::*
        proc r {} {}
        list [info procs] [info procs p*]
    }
} {{p q r} p}

set self info.test
if {$tcl_platform(os) == "Win32s"} {
    set self info~1.tes
}

test info-16.1 {info script option} {
    list [catch {info script x} msg] $msg
} {1 {wrong # args: should be "info script"}}
test info-16.2 {info script option} {
    file tail [info sc]
} $self
removeFile gorp.info
makeFile "info script\n" gorp.info
test info-16.3 {info script option} {
    list [source gorp.info] [file tail [info script]]
} [list gorp.info $self]
test info-16.4 {resetting "info script" after errors} {
    catch {source ~_nobody_/foo}
    file tail [info script]
} $self
test info-16.5 {resetting "info script" after errors} {
    catch {source _nonexistent_}
    file tail [info script]
} $self
removeFile gorp.info

test info-17.1 {info sharedlibextension option} {
    list [catch {info sharedlibextension foo} msg] $msg
} {1 {wrong # args: should be "info sharedlibextension"}}

test info-18.1 {info tclversion option} {
................................................................................
} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-20.5 {miscellaneous error conditions} {
    list [catch {info s} msg] $msg
} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}

# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::test::cleanupTests
return

















|

|







 







<
<
<
<
<





|




|



|



|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
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
...
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
# Copyright (c) 1991-1994 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: info.test,v 1.1.2.4 1999/03/23 20:06:30 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.

catch {namespace delete test_ns_info1 test_ns_info2}
................................................................................
    namespace eval test_ns_info2 {
        namespace import ::test_ns_info1::*
        proc r {} {}
        list [info procs] [info procs p*]
    }
} {{p q r} p}






test info-16.1 {info script option} {
    list [catch {info script x} msg] $msg
} {1 {wrong # args: should be "info script"}}
test info-16.2 {info script option} {
    file tail [info sc]
} "info.test"
removeFile gorp.info
makeFile "info script\n" gorp.info
test info-16.3 {info script option} {
    list [source gorp.info] [file tail [info script]]
} [list gorp.info info.test]
test info-16.4 {resetting "info script" after errors} {
    catch {source ~_nobody_/foo}
    file tail [info script]
} "info.test"
test info-16.5 {resetting "info script" after errors} {
    catch {source _nonexistent_}
    file tail [info script]
} "info.test"
removeFile gorp.info

test info-17.1 {info sharedlibextension option} {
    list [catch {info sharedlibextension foo} msg] $msg
} {1 {wrong # args: should be "info sharedlibextension"}}

test info-18.1 {info tclversion option} {
................................................................................
} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-20.5 {miscellaneous error conditions} {
    list [catch {info s} msg] $msg
} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}

# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return











Changes to tests/init.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
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
...
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
...
145
146
147
148
149
150
151
152
153
154










#
# 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.
#
# RCS: @(#) $Id: init.test,v 1.1.2.3 1999/03/11 18:49:45 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Clear out any namespaces called test_ns_*
catch {eval namespace delete [namespace children :: test_ns_*]}

# Six cases - white box testing
................................................................................


# we use a sub interp and auto_reset and double the tests because there is 2
# places where auto_loading occur (before loading the indexes files and after)

set testInterp [interp create]
interp eval $testInterp [list set argv $argv]
interp eval $testInterp [list source [file join $::test::testsDir defs.tcl]]

interp eval $testInterp {

if {[string compare test [info procs test]] == 1} then {source defs}

auto_reset
catch {rename parray {}}

test init-2.0 {load parray - stage 1} {
    set ret [catch {namespace eval ::test {parray}} error]
    rename parray {} ; # remove it, for the next test - that should not fail.
    list $ret $error
} {1 {no value given for parameter "a" to "parray"}}


test init-2.1 {load parray - stage 2} {
    set ret [catch {namespace eval ::test {parray}} error]
    list $ret $error
} {1 {no value given for parameter "a" to "parray"}}


auto_reset
catch {rename ::safe::setLogCmd {}}
#unset auto_index(::safe::setLogCmd)
................................................................................

auto_reset
package require http 2.0
catch {rename ::http::geturl {}}

test init-2.8 {load http::geturl (package)} {
    # 3 ':' on purpose
    set ret [catch {namespace eval ::test {http:::geturl}} error]
    # removing it, for the next test. should not fail.
    rename ::http::geturl {} ; 
    list $ret $error
} {1 {no value given for parameter "url" to "http:::geturl"}}


test init-3.0 {random stuff in the auto_index, should still work} {
................................................................................
    foo:::bar::blah
} 1

}

# cleanup
interp delete $testInterp
::test::cleanupTests
return

















|

|







 







|









|






|







 







|







 







|


>
>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
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
...
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
...
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
#
# 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.
#
# RCS: @(#) $Id: init.test,v 1.1.2.4 1999/03/23 20:06:30 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Clear out any namespaces called test_ns_*
catch {eval namespace delete [namespace children :: test_ns_*]}

# Six cases - white box testing
................................................................................


# we use a sub interp and auto_reset and double the tests because there is 2
# places where auto_loading occur (before loading the indexes files and after)

set testInterp [interp create]
interp eval $testInterp [list set argv $argv]
interp eval $testInterp [list source [file join $::tcltest::testsDir defs.tcl]]

interp eval $testInterp {

if {[string compare test [info procs test]] == 1} then {source defs}

auto_reset
catch {rename parray {}}

test init-2.0 {load parray - stage 1} {
    set ret [catch {namespace eval ::tcltest {parray}} error]
    rename parray {} ; # remove it, for the next test - that should not fail.
    list $ret $error
} {1 {no value given for parameter "a" to "parray"}}


test init-2.1 {load parray - stage 2} {
    set ret [catch {namespace eval ::tcltest {parray}} error]
    list $ret $error
} {1 {no value given for parameter "a" to "parray"}}


auto_reset
catch {rename ::safe::setLogCmd {}}
#unset auto_index(::safe::setLogCmd)
................................................................................

auto_reset
package require http 2.0
catch {rename ::http::geturl {}}

test init-2.8 {load http::geturl (package)} {
    # 3 ':' on purpose
    set ret [catch {namespace eval ::tcltest {http:::geturl}} error]
    # removing it, for the next test. should not fail.
    rename ::http::geturl {} ; 
    list $ret $error
} {1 {no value given for parameter "url" to "http:::geturl"}}


test init-3.0 {random stuff in the auto_index, should still work} {
................................................................................
    foo:::bar::blah
} 1

}

# cleanup
interp delete $testInterp
::tcltest::cleanupTests
return











Changes to tests/interp.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
....
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
....
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338










#
# 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.
#
# RCS: @(#) $Id: interp.test,v 1.1.2.6 1999/03/11 18:49:46 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# The set of hidden commands is platform dependent:

if {"$tcl_platform(platform)" == "macintosh"} {
    set hidden_cmds {beep cd echo exit fconfigure file glob load ls open pwd socket source}
................................................................................
    lappend l [interp hidden a]
    a alias bar {}
    lappend l [interp aliases a]
    lappend l [interp hidden a]
    interp delete a
    set l
} {{} bar {} bar bar {} {}}
test interp-23.2 {testing hiding vs aliases} {pc || unix} {
    catch {interp delete a}
    interp create a -safe
    set l ""
    lappend l [lsort [interp hidden a]]
    a alias bar bar
    lappend l [interp aliases a]
    lappend l [lsort [interp hidden a]]
................................................................................
#     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}]];
#     namespace delete mfoo;
#     interp delete $i;
#     set res
# } {{slave bar called (foo-slave) (bar test1) (::test) (::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} {
#    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;
................................................................................
    $i alias ns::cmd {}
} {}

# cleanup
foreach i [interp slaves] {
  interp delete $i
}
::test::cleanupTests
return

















|

|







 







|







 







|







 







|


>
>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
....
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
....
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
#
# 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.
#
# RCS: @(#) $Id: interp.test,v 1.1.2.7 1999/03/23 20:06:31 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# The set of hidden commands is platform dependent:

if {"$tcl_platform(platform)" == "macintosh"} {
    set hidden_cmds {beep cd echo exit fconfigure file glob load ls open pwd socket source}
................................................................................
    lappend l [interp hidden a]
    a alias bar {}
    lappend l [interp aliases a]
    lappend l [interp hidden a]
    interp delete a
    set l
} {{} bar {} bar bar {} {}}
test interp-23.2 {testing hiding vs aliases} {unixOrPc} {
    catch {interp delete a}
    interp create a -safe
    set l ""
    lappend l [lsort [interp hidden a]]
    a alias bar bar
    lappend l [interp aliases a]
    lappend l [lsort [interp hidden a]]
................................................................................
#     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}]];
#     namespace delete mfoo;
#     interp delete $i;
#     set res
# } {{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} {
#    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;
................................................................................
    $i alias ns::cmd {}
} {}

# cleanup
foreach i [interp slaves] {
  interp delete $i
}
::tcltest::cleanupTests
return











Changes to tests/io.test.

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
..
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
....
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
....
2016
2017
2018
2019
2020
2021
2022
2023

2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037

2038
2039
2040
2041
2042
2043
2044
....
2097
2098
2099
2100
2101
2102
2103
2104

2105
2106
2107
2108
2109
2110
2111
....
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
....
2627
2628
2629
2630
2631
2632
2633
2634

2635
2636
2637
2638
2639
2640
2641
....
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
....
5279
5280
5281
5282
5283
5284
5285

5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
....
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
....
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
....
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
....
6779
6780
6781
6782
6783
6784
6785
6786
6787
6788
6789
6790
6791
6792










# Copyright (c) 1991-1994 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: io.test,v 1.1.2.8 1999/03/11 18:49:46 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {"[info commands testchannel]" != "testchannel"} {
    puts "Skipping io tests. This application does not seem to have the"
    puts "testchannel command that is needed to run these tests."
    return
}

::test::saveState

removeFile test1
removeFile pipe




# set up a long data file for some of the following tests

set f [open longfile w]
fconfigure $f -eofchar {} -translation lf
for { set i 0 } { $i < 100 } { incr i} {
    puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef
\#123456789abcdef01
................................................................................
	    close $f
	    exit 0
	}
    }
    vwait forever
} cat

set thisScript [file join $::test::testsDir [info script]]

# These tests are disabled until we decide what to do with "unsupported0".
#
#test io-1.1 {unsupported0 command} {
#    removeFile test1
#    set f1 [open iocmd.test]
#    set f2 [open test1 w]
................................................................................
    set f [open test1 w]
    set x [fconfigure $f -encoding]
    close $f
    encoding system $old
	close $a
    set x
} {ascii}    
test io-20.2 {Tcl_CreateChannel: initial settings} {pc} {
    set f [open test1 w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} [list [list \x1a ""] {auto crlf}]
test io-20.3 {Tcl_CreateChannel: initial settings} {unix} {
    set f [open test1 w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} {{{} {}} {auto lf}}
test io-20.4 {Tcl_CreateChannel: initial settings} {mac} {
    set f [open test1 w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} {{{} {}} {auto cr}}
test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio} {
    set f [open script w]
................................................................................
    }
    lappend l [file size test1]
    flush $f
    lappend l [file size test1]
    close $f
    set l
} {0 60 72}
test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} {unixOrPc} {

    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -buffersize 60 -eofchar {}
    set l ""
    lappend l [file size test1]
    for {set i 0} {$i < 12} {incr i} {
	puts $f hello
    }
    lappend l [file size test1]
    close $f
    lappend l [file size test1]
    set l
} {0 60 72}
test io-27.6 {FlushChannel, async flushing, async close} {stdio && asyncPipeClose} {

    removeFile pipe
    removeFile output
    set f [open pipe w]
    puts $f {
	set f [open output w]
	fconfigure $f -translation lf -buffering none -eofchar {}
	while {![eof stdin]} {
................................................................................
    x eval close $f
    interp delete x
    set f [open test1 r]
    set l [gets $f]
    close $f
    set l
} abcdef
test io-28.3 {CloseChannel, not called before output queue is empty} {stdio asyncPipeClose nonPortable} {

    removeFile pipe
    removeFile output
    set f [open pipe w]
    puts $f {

	# Need to not have eof char appended on close, because the other
	# side of the pipe already closed, so that writing would cause an
................................................................................
    close $f
    after 100
    set f [open test3 r]
    set x [read $f]
    close $f
    set x
} "Line 1\nLine 2\n"
test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio && unixExecs} {
    set f [open "|[list cat -u]" r+]
    puts $f "Line1"
    flush $f
    set x [gets $f]
    close $f
    set x
} {Line1}
................................................................................
    }
    if {$counter == 1000} {
	set result "file size only [file size output]"
    } else {
	set result ok
    }
} ok
test io-29.32 {Tcl_WriteChars, background flush to slow reader} {stdio && asyncPipeClose} {

    removeFile pipe
    removeFile output
    set f [open pipe w]
    puts $f {set f [open output w]}
    puts $f {fconfigure $f -translation lf}
    set x [list while {![eof stdin]}]
    set x "$x {"
................................................................................
    puts $f "line 1"
    close $f
    set f [open test3 r]
    lappend x [gets $f]
    close $f
    set x
} {0600 {line 1}}
test io-40.3 {POSIX open access modes: CREAT} {$::test::testConfig(unix) && ([exec umask] == 2)} {
    # This test only works if your umask is 2, like ouster's.
    removeFile test3
    set f [open test3 {WRONLY CREAT}]
    close $f
    file stat test3 stats
    format "0%o" [expr $stats(mode)&0777]
} 0664
................................................................................
    fileevent $f r "new scr\0ipt"
    lappend result [string length [fileevent $f readable]]
    fileevent $f r "yet ano\0ther"
    lappend result [string length [fileevent $f readable]]
    fileevent $f r ""
    lappend result [fileevent $f readable]
} {13 11 12 {}}

#
# Test fileevent on a pipe
#

if {$::test::testConfig(stdio) && $::test::testConfig(unixExecs)} {

catch {set f2 [open "|[list cat -u]" r+]}
catch {set f3 [open "|[list cat -u]" r+]}

test io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {
    set result {}
    fileevent $f readable "script 1"
    lappend result [fileevent $f readable] [fileevent $f writable]
    fileevent $f writable "write script"
    lappend result [fileevent $f readable] [fileevent $f writable]
    fileevent $f readable {}
    lappend result [fileevent $f readable] [fileevent $f writable]
    fileevent $f writable {}
    lappend result [fileevent $f readable] [fileevent $f writable]
} {{script 1} {} {script 1} {write script} {} {write script} {} {}}
test io-43.2 {Tcl_FileeventCmd: deleting when many present} {
    set result {}
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
    fileevent $f r "read f"
    fileevent $f2 r "read f2"
    fileevent $f3 r "read f3"
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
    fileevent $f2 r {}
................................................................................
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
    fileevent $f3 r {}
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
    fileevent $f r {}
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
} {{} {} {} {read f} {read f2} {read f3} {read f} {} {read f3} {read f} {} {} {} {} {}}

test io-44.1 {FileEventProc procedure: normal read event} {
    fileevent $f2 readable {
	set x [gets $f2]; fileevent $f2 readable {}
    }
    puts $f2 text; flush $f2
    set x initial
    vwait x
    set x
} {text}
test io-44.2 {FileEventProc procedure: error in read event} {
    proc bgerror args {
	global x
	set x $args
    }
    fileevent $f2 readable {error bogus}
    puts $f2 text; flush $f2
    set x initial
    vwait x
    rename bgerror {}
    list $x [fileevent $f2 readable]
} {bogus {}}
test io-44.3 {FileEventProc procedure: normal write event} {
    fileevent $f2 writable {
	lappend x "triggered"
	incr count -1
	if {$count <= 0} {
	    fileevent $f2 writable {}
	}
    }
................................................................................
    set x initial
    set count 3
    vwait x
    vwait x
    vwait x
    set x
} {initial triggered triggered triggered}
test io-44.4 {FileEventProc procedure: eror in write event} {
    proc bgerror args {
	global x
	set x $args
    }
    fileevent $f2 writable {error bad-write}
    set x initial
    vwait x
    rename bgerror {}
    list $x [fileevent $f2 writable]
} {bad-write {}}
test io-44.5 {FileEventProc procedure: end of file} {
    set f4 [open "|[list $tcltest cat << foo]" r]
    fileevent $f4 readable {
	if {[gets $f4 line] < 0} {
	    lappend x eof
	    fileevent $f4 readable {}
	} else {
	    lappend x $line
................................................................................
    close $f4
    set x
} {initial foo eof}

catch {close $f2}
catch {close $f3}

}
	# Closes if {($platform(platform) != "macintosh") && \
	#		($::test::testConfig(unixExecs) == 1)} clause

close $f
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {
    set f [open foo r]
    fileevent $f readable {
	lappend x "binding triggered: \"[gets $f]\""
................................................................................
    vwait x
    list $x $result
} {1 {gets {normal message from pipe} gets {} catch {error message from pipe}}}

# cleanup
foreach file [list fooBar longfile script output test1 pipe my_script foo \
	bar test2 test3 cat stdout] {
    ::test::removeFile $file
}
restoreState
::test::cleanupTests
return


















|

|









|




>
>
>







 







|







 







|





|





|







 







|
>













|
>







 







|
>







 







|







 







|
>







 







|







 







>




<
<



|










|







 







|








|











|







 







|










|







 







<
<
<







 







|


|



>
>
>
>
>
>
>
>
>
>
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
..
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
....
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
....
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
....
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
....
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
....
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
....
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
....
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297


5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
....
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
....
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
....
5387
5388
5389
5390
5391
5392
5393



5394
5395
5396
5397
5398
5399
5400
....
6782
6783
6784
6785
6786
6787
6788
6789
6790
6791
6792
6793
6794
6795
6796
6797
6798
6799
6800
6801
6802
6803
6804
6805
# Copyright (c) 1991-1994 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: io.test,v 1.1.2.9 1999/03/23 20:06:32 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {"[info commands testchannel]" != "testchannel"} {
    puts "Skipping io tests. This application does not seem to have the"
    puts "testchannel command that is needed to run these tests."
    return
}

::tcltest::saveState

removeFile test1
removeFile pipe

# some tests can only be run is umask is 2
set ::tcltest::testConfig(umask2) [expr {[exec umask] == 2}]

# set up a long data file for some of the following tests

set f [open longfile w]
fconfigure $f -eofchar {} -translation lf
for { set i 0 } { $i < 100 } { incr i} {
    puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef
\#123456789abcdef01
................................................................................
	    close $f
	    exit 0
	}
    }
    vwait forever
} cat

set thisScript [file join $::tcltest::testsDir [info script]]

# These tests are disabled until we decide what to do with "unsupported0".
#
#test io-1.1 {unsupported0 command} {
#    removeFile test1
#    set f1 [open iocmd.test]
#    set f2 [open test1 w]
................................................................................
    set f [open test1 w]
    set x [fconfigure $f -encoding]
    close $f
    encoding system $old
	close $a
    set x
} {ascii}    
test io-20.2 {Tcl_CreateChannel: initial settings} {pcOnly} {
    set f [open test1 w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} [list [list \x1a ""] {auto crlf}]
test io-20.3 {Tcl_CreateChannel: initial settings} {unixOnly} {
    set f [open test1 w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} {{{} {}} {auto lf}}
test io-20.4 {Tcl_CreateChannel: initial settings} {macOnly} {
    set f [open test1 w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} {{{} {}} {auto cr}}
test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio} {
    set f [open script w]
................................................................................
    }
    lappend l [file size test1]
    flush $f
    lappend l [file size test1]
    close $f
    set l
} {0 60 72}
test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \
	{unixOrPc} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -buffersize 60 -eofchar {}
    set l ""
    lappend l [file size test1]
    for {set i 0} {$i < 12} {incr i} {
	puts $f hello
    }
    lappend l [file size test1]
    close $f
    lappend l [file size test1]
    set l
} {0 60 72}
test io-27.6 {FlushChannel, async flushing, async close} \
	{stdio asyncPipeClose} {
    removeFile pipe
    removeFile output
    set f [open pipe w]
    puts $f {
	set f [open output w]
	fconfigure $f -translation lf -buffering none -eofchar {}
	while {![eof stdin]} {
................................................................................
    x eval close $f
    interp delete x
    set f [open test1 r]
    set l [gets $f]
    close $f
    set l
} abcdef
test io-28.3 {CloseChannel, not called before output queue is empty} \
	{stdio asyncPipeClose nonPortable} {
    removeFile pipe
    removeFile output
    set f [open pipe w]
    puts $f {

	# Need to not have eof char appended on close, because the other
	# side of the pipe already closed, so that writing would cause an
................................................................................
    close $f
    after 100
    set f [open test3 r]
    set x [read $f]
    close $f
    set x
} "Line 1\nLine 2\n"
test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs} {
    set f [open "|[list cat -u]" r+]
    puts $f "Line1"
    flush $f
    set x [gets $f]
    close $f
    set x
} {Line1}
................................................................................
    }
    if {$counter == 1000} {
	set result "file size only [file size output]"
    } else {
	set result ok
    }
} ok
test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
	{stdio asyncPipeClose} {
    removeFile pipe
    removeFile output
    set f [open pipe w]
    puts $f {set f [open output w]}
    puts $f {fconfigure $f -translation lf}
    set x [list while {![eof stdin]}]
    set x "$x {"
................................................................................
    puts $f "line 1"
    close $f
    set f [open test3 r]
    lappend x [gets $f]
    close $f
    set x
} {0600 {line 1}}
test io-40.3 {POSIX open access modes: CREAT} {unixOnly umask2} {
    # This test only works if your umask is 2, like ouster's.
    removeFile test3
    set f [open test3 {WRONLY CREAT}]
    close $f
    file stat test3 stats
    format "0%o" [expr $stats(mode)&0777]
} 0664
................................................................................
    fileevent $f r "new scr\0ipt"
    lappend result [string length [fileevent $f readable]]
    fileevent $f r "yet ano\0ther"
    lappend result [string length [fileevent $f readable]]
    fileevent $f r ""
    lappend result [fileevent $f readable]
} {13 11 12 {}}

#
# Test fileevent on a pipe
#



catch {set f2 [open "|[list cat -u]" r+]}
catch {set f3 [open "|[list cat -u]" r+]}

test io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixExecs} {
    set result {}
    fileevent $f readable "script 1"
    lappend result [fileevent $f readable] [fileevent $f writable]
    fileevent $f writable "write script"
    lappend result [fileevent $f readable] [fileevent $f writable]
    fileevent $f readable {}
    lappend result [fileevent $f readable] [fileevent $f writable]
    fileevent $f writable {}
    lappend result [fileevent $f readable] [fileevent $f writable]
} {{script 1} {} {script 1} {write script} {} {write script} {} {}}
test io-43.2 {Tcl_FileeventCmd: deleting when many present} {stdio unixExecs} {
    set result {}
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
    fileevent $f r "read f"
    fileevent $f2 r "read f2"
    fileevent $f3 r "read f3"
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
    fileevent $f2 r {}
................................................................................
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
    fileevent $f3 r {}
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
    fileevent $f r {}
    lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
} {{} {} {} {read f} {read f2} {read f3} {read f} {} {read f3} {read f} {} {} {} {} {}}

test io-44.1 {FileEventProc procedure: normal read event} {stdio unixExecs} {
    fileevent $f2 readable {
	set x [gets $f2]; fileevent $f2 readable {}
    }
    puts $f2 text; flush $f2
    set x initial
    vwait x
    set x
} {text}
test io-44.2 {FileEventProc procedure: error in read event} {stdio unixExecs} {
    proc bgerror args {
	global x
	set x $args
    }
    fileevent $f2 readable {error bogus}
    puts $f2 text; flush $f2
    set x initial
    vwait x
    rename bgerror {}
    list $x [fileevent $f2 readable]
} {bogus {}}
test io-44.3 {FileEventProc procedure: normal write event} {stdio unixExecs} {
    fileevent $f2 writable {
	lappend x "triggered"
	incr count -1
	if {$count <= 0} {
	    fileevent $f2 writable {}
	}
    }
................................................................................
    set x initial
    set count 3
    vwait x
    vwait x
    vwait x
    set x
} {initial triggered triggered triggered}
test io-44.4 {FileEventProc procedure: eror in write event} {stdio unixExecs} {
    proc bgerror args {
	global x
	set x $args
    }
    fileevent $f2 writable {error bad-write}
    set x initial
    vwait x
    rename bgerror {}
    list $x [fileevent $f2 writable]
} {bad-write {}}
test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs} {
    set f4 [open "|[list $tcltest cat << foo]" r]
    fileevent $f4 readable {
	if {[gets $f4 line] < 0} {
	    lappend x eof
	    fileevent $f4 readable {}
	} else {
	    lappend x $line
................................................................................
    close $f4
    set x
} {initial foo eof}

catch {close $f2}
catch {close $f3}





close $f
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {
    set f [open foo r]
    fileevent $f readable {
	lappend x "binding triggered: \"[gets $f]\""
................................................................................
    vwait x
    list $x $result
} {1 {gets {normal message from pipe} gets {} catch {error message from pipe}}}

# cleanup
foreach file [list fooBar longfile script output test1 pipe my_script foo \
	bar test2 test3 cat stdout] {
    ::tcltest::removeFile $file
}
restoreState
::tcltest::cleanupTests
return












Changes to tests/ioCmd.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
...
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518










# Copyright (c) 1991-1994 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.
#
# RCS: @(#) $Id: ioCmd.test,v 1.1.2.4 1999/03/11 18:49:47 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

removeFile test1
removeFile pipe

set executable [list [info nameofexecutable]]
................................................................................
test iocmd-8.18 {fconfigure command / unix tty channel} {nonPortable unixOnly} {
	# might fail if /dev/ttya is unavailable
	set tty [open /dev/ttya]
	set r [list [catch {fconfigure $tty -blah blih} msg] $msg];
	close $tty;
	set r;
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, or -mode}}
test iocmd-8.19 {fconfigure command / win tty channel} {pcOnly && !win32s} {
	# None of the com port functions are implemented on Win32s.
	# Also, might fail if com1 is unavailable
	set tty [open com1]
	set r [list [catch {fconfigure $tty -blah blih} msg] $msg];
	close $tty;
	set r;
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, or -mode}}

test iocmd-9.1 {eof command} {
................................................................................
} {1 {expected integer but got "foo"}}

close $rfile
close $wfile

# cleanup
foreach file [list test1 test2 test3 test4] {
    ::test::removeFile $file
}
# delay long enough for background processes to finish
after 500
foreach file [list test5 pipe output] {
    ::test::removeFile $file
}
::test::cleanupTests
return

















|

|







 







|
<
|







 







|




|

|


>
>
>
>
>
>
>
>
>
>
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
292
293
294
295
296
297
298
299

300
301
302
303
304
305
306
307
...
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
# Copyright (c) 1991-1994 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.
#
# RCS: @(#) $Id: ioCmd.test,v 1.1.2.5 1999/03/23 20:06:33 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

removeFile test1
removeFile pipe

set executable [list [info nameofexecutable]]
................................................................................
test iocmd-8.18 {fconfigure command / unix tty channel} {nonPortable unixOnly} {
	# might fail if /dev/ttya is unavailable
	set tty [open /dev/ttya]
	set r [list [catch {fconfigure $tty -blah blih} msg] $msg];
	close $tty;
	set r;
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, or -mode}}
test iocmd-8.19 {fconfigure command / win tty channel} {pcOnly} {

	# might fail if com1 is unavailable
	set tty [open com1]
	set r [list [catch {fconfigure $tty -blah blih} msg] $msg];
	close $tty;
	set r;
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, or -mode}}

test iocmd-9.1 {eof command} {
................................................................................
} {1 {expected integer but got "foo"}}

close $rfile
close $wfile

# cleanup
foreach file [list test1 test2 test3 test4] {
    ::tcltest::removeFile $file
}
# delay long enough for background processes to finish
after 500
foreach file [list test5 pipe output] {
    ::tcltest::removeFile $file
}
::tcltest::cleanupTests
return











Changes to tests/ioUtil.test.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
298
299
300
301
302
303
304
305
306
307










# 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. 
# 
# RCS: @(#) $Id: ioUtil.test,v 1.1.2.4 1999/03/11 18:49:48 hershey Exp $
 
if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set unsetScript {
    catch {unset testStat1(size)}
    catch {unset testStat2(size)}
    catch {unset testStat3(size)}
................................................................................
    catch {testopenfilechannelproc delete TestOpenFileChannelProc3} err11

    list $err9 $err10 $err11
} {{"TestOpenFileChannelProc1": could not be deleteed} {"TestOpenFileChannelProc2": could not be deleteed} {"TestOpenFileChannelProc3": could not be deleteed}}
}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
# 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. 
# 
# RCS: @(#) $Id: ioUtil.test,v 1.1.2.5 1999/03/23 20:06:33 hershey Exp $
 
if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set unsetScript {
    catch {unset testStat1(size)}
    catch {unset testStat2(size)}
    catch {unset testStat3(size)}
................................................................................
    catch {testopenfilechannelproc delete TestOpenFileChannelProc3} err11

    list $err9 $err10 $err11
} {{"TestOpenFileChannelProc1": could not be deleteed} {"TestOpenFileChannelProc2": could not be deleteed} {"TestOpenFileChannelProc3": could not be deleteed}}
}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/join.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
45
46
47
48
49
50
51
52
53
54










# 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.
#
# RCS: @(#) $Id: join.test,v 1.1.2.3 1999/03/11 18:49:48 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test join-1.1 {basic join commands} {
    join {a b c} xyz
} axyzbxyzc
test join-1.2 {basic join commands} {
................................................................................
} 9

test join-3.2 {join is binary ok} {
  string length [join "a\0b a\0b a\0b"]
} 11

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
# 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.
#
# RCS: @(#) $Id: join.test,v 1.1.2.4 1999/03/23 20:06:34 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test join-1.1 {basic join commands} {
    join {a b c} xyz
} axyzbxyzc
test join-1.2 {basic join commands} {
................................................................................
} 9

test join-3.2 {join is binary ok} {
  string length [join "a\0b a\0b a\0b"]
} 11

# cleanup
::tcltest::cleanupTests
return











Changes to tests/lindex.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
73
74
75
76
77
78
79
80
81
82










# 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.
#
# RCS: @(#) $Id: lindex.test,v 1.1.2.3 1999/03/11 18:49:49 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test lindex-1.1 {basic tests} {
    lindex {a b c} 0} a
test lindex-1.2 {basic tests} {
    lindex {a {b c d} x} 1} {b c d}
................................................................................
    lindex {ab "c d \" x" y} 1
} {c d " x}
test lindex-3.4 {quoted elements} {
    lindex {a b {c d "e} {f g"}} 2
} {c d "e}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
# 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.
#
# RCS: @(#) $Id: lindex.test,v 1.1.2.4 1999/03/23 20:06:34 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test lindex-1.1 {basic tests} {
    lindex {a b c} 0} a
test lindex-1.2 {basic tests} {
    lindex {a {b c d} x} 1} {b c d}
................................................................................
    lindex {ab "c d \" x" y} 1
} {c d " x}
test lindex-3.4 {quoted elements} {
    lindex {a b {c d "e} {f g"}} 2
} {c d "e}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/link.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
234
235
236
237
238
239
240
241
242
243










# 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.
#
# RCS: @(#) $Id: link.test,v 1.1.2.3 1999/03/11 18:49:49 hershey Exp $

if {[info commands testlink] == {}} {
    puts "This application hasn't been compiled with the \"testlink\""
    puts "command, so I can't test Tcl_LinkVar et al."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

foreach i {int real bool string} {
    catch {unset $i}
}
test link-1.1 {reading C variables from Tcl} {
................................................................................
testlink set 0 0 0 -
testlink delete
foreach i {int real bool string} {
    catch {unset $i}
}

# cleanup
::test::cleanupTests
return

















|







|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
# 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.
#
# RCS: @(#) $Id: link.test,v 1.1.2.4 1999/03/23 20:06:35 hershey Exp $

if {[info commands testlink] == {}} {
    puts "This application hasn't been compiled with the \"testlink\""
    puts "command, so I can't test Tcl_LinkVar et al."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

foreach i {int real bool string} {
    catch {unset $i}
}
test link-1.1 {reading C variables from Tcl} {
................................................................................
testlink set 0 0 0 -
testlink delete
foreach i {int real bool string} {
    catch {unset $i}
}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/linsert.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
103
104
105
106
107
108
109
110
111
112










# 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.
#
# RCS: @(#) $Id: linsert.test,v 1.1.2.3 1999/03/11 18:49:50 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset lis}
catch {rename p ""}

test linsert-1.1 {linsert command} {
................................................................................
    set lis [format "a \"%s\" c" "b"]
    linsert $lis 0 [string length $lis]
} "7 a b c"

# cleanup
catch {unset lis}
catch {rename p ""}
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
# 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.
#
# RCS: @(#) $Id: linsert.test,v 1.1.2.4 1999/03/23 20:06:35 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset lis}
catch {rename p ""}

test linsert-1.1 {linsert command} {
................................................................................
    set lis [format "a \"%s\" c" "b"]
    linsert $lis 0 [string length $lis]
} "7 a b c"

# cleanup
catch {unset lis}
catch {rename p ""}
::tcltest::cleanupTests
return











Changes to tests/list.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
106
107
108
109
110
111
112
113
114
115










# 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.
#
# RCS: @(#) $Id: list.test,v 1.1.2.3 1999/03/11 18:49:51 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# 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}
................................................................................
    return [concat $result $list]
}
test list-3.1 {SetListFromAny and lrange/concat results} {
    slowsort {fred julie alex carol bill annie}
} {alex annie bill carol fred julie}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
# 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.
#
# RCS: @(#) $Id: list.test,v 1.1.2.4 1999/03/23 20:06:36 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# 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}
................................................................................
    return [concat $result $list]
}
test list-3.1 {SetListFromAny and lrange/concat results} {
    slowsort {fred julie alex carol bill annie}
} {alex annie bill carol fred julie}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/listObj.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
178
179
180
181
182
183
184
185
186
187










#
# 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.
#
# RCS: @(#) $Id: listObj.test,v 1.1.2.3 1999/03/11 18:49:51 hershey Exp $

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} {
    set t [testobj types]
    set first [string first "list" $t]
................................................................................
} "foo\x00help"

test listobj-9.1 {UpdateStringOfList} {
    string length [list foo\x00help]
} 8

# cleanup
::test::cleanupTests
return

















|







|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
#
# 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.
#
# RCS: @(#) $Id: listObj.test,v 1.1.2.4 1999/03/23 20:06:36 hershey Exp $

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} {
    set t [testobj types]
    set first [string first "list" $t]
................................................................................
} "foo\x00help"

test listobj-9.1 {UpdateStringOfList} {
    string length [list foo\x00help]
} 8

# cleanup
::tcltest::cleanupTests
return











Changes to tests/llength.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
34
35
36
37
38
39
40
41
42
43










# 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.
#
# RCS: @(#) $Id: llength.test,v 1.1.2.3 1999/03/11 18:49:52 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test llength-1.1 {length of list} {
    llength {a b c d}
} 4
test llength-1.2 {length of list} {
................................................................................
    list [catch {llength 123 2} msg] $msg
} {1 {wrong # args: should be "llength list"}}
test llength-2.3 {error conditions} {
    list [catch {llength "a b c \{"} msg] $msg
} {1 {unmatched open brace in list}}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
# 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.
#
# RCS: @(#) $Id: llength.test,v 1.1.2.4 1999/03/23 20:06:37 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test llength-1.1 {length of list} {
    llength {a b c d}
} 4
test llength-1.2 {length of list} {
................................................................................
    list [catch {llength 123 2} msg] $msg
} {1 {wrong # args: should be "llength list"}}
test llength-2.3 {error conditions} {
    list [catch {llength "a b c \{"} msg] $msg
} {1 {unmatched open brace in list}}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/load.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
163
164
165
166
167
168
169
170
171
172










#
# 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.
#
# RCS: @(#) $Id: load.test,v 1.1.2.4 1999/03/11 18:49:52 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Figure out what extension is used for shared libraries on this
# platform.

if {$tcl_platform(platform) == "macintosh"} {
................................................................................
	load [file join $testDir pkgb$ext] pkgb
	list [info loaded {}] [lsort [info commands pkgb_*]]
    } "{{[file join $testDir pkgb$ext] Pkgb} {{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} $alreadyLoaded} {pkgb_sub pkgb_unsafe}"
    interp delete child
}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
#
# 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.
#
# RCS: @(#) $Id: load.test,v 1.1.2.5 1999/03/23 20:06:38 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Figure out what extension is used for shared libraries on this
# platform.

if {$tcl_platform(platform) == "macintosh"} {
................................................................................
	load [file join $testDir pkgb$ext] pkgb
	list [info loaded {}] [lsort [info commands pkgb_*]]
    } "{{[file join $testDir pkgb$ext] Pkgb} {{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} $alreadyLoaded} {pkgb_sub pkgb_unsafe}"
    interp delete child
}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/lrange.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
82
83
84
85
86
87
88
89
90
91










# 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.
#
# RCS: @(#) $Id: lrange.test,v 1.1.2.3 1999/03/11 18:49:53 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test lrange-1.1 {range of list elements} {
    lrange {a b c d} 1 2
} {b c}
test lrange-1.2 {range of list elements} {
................................................................................
    list [catch {lrange "a \{b c" 3 4} msg] $msg
} {1 {unmatched open brace in list}}
test lrange-2.6 {error conditions} {
    list [catch {lrange "a b c \{ d e" 1 4} msg] $msg
} {1 {unmatched open brace in list}}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
# 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.
#
# RCS: @(#) $Id: lrange.test,v 1.1.2.4 1999/03/23 20:06:39 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test lrange-1.1 {range of list elements} {
    lrange {a b c d} 1 2
} {b c}
test lrange-1.2 {range of list elements} {
................................................................................
    list [catch {lrange "a \{b c" 3 4} msg] $msg
} {1 {unmatched open brace in list}}
test lrange-2.6 {error conditions} {
    list [catch {lrange "a b c \{ d e" 1 4} msg] $msg
} {1 {unmatched open brace in list}}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/lreplace.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
129
130
131
132
133
134
135
136
137
138










# 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.
#
# RCS: @(#) $Id: lreplace.test,v 1.1.2.3 1999/03/11 18:49:54 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

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} {
................................................................................
        return "a b c"
    }
    p
} "a b c"

# cleanup
catch {unset foo}
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
# 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.
#
# RCS: @(#) $Id: lreplace.test,v 1.1.2.4 1999/03/23 20:06:39 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

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} {
................................................................................
        return "a b c"
    }
    p
} "a b c"

# cleanup
catch {unset foo}
::tcltest::cleanupTests
return











Changes to tests/lsearch.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
85
86
87
88
89
90
91
92
93
94










# 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.
#
# RCS: @(#) $Id: lsearch.test,v 1.1.2.4 1999/03/11 18:49:54 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set x {abcd bbcd 123 234 345}
test lsearch-1.1 {lsearch command} {
    lsearch $x 123
} 2
................................................................................
    set x one
    append x \x00
    append x two
    lsearch -exact [list foo one\000two bar] $x
} 1

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
# 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.
#
# RCS: @(#) $Id: lsearch.test,v 1.1.2.5 1999/03/23 20:06:40 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set x {abcd bbcd 123 234 345}
test lsearch-1.1 {lsearch command} {
    lsearch $x 123
} 2
................................................................................
    set x one
    append x \x00
    append x two
    lsearch -exact [list foo one\000two bar] $x
} 1

# cleanup
::tcltest::cleanupTests
return











Changes to tests/macFCmd.test.

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










#
# 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.
#
# RCS: @(#) $Id: macFCmd.test,v 1.1.2.3 1999/03/11 18:49:54 hershey Exp $
#

if {$tcl_platform(platform) != "macintosh"} {
    puts "skipping: Mac only tests..."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {file delete -force foo.dir}
file mkdir foo.dir
if {[catch {file attributes foo.dir -readonly 1}]} {
    set ::test::testConfig(fileSharing) 0
    set ::test::testConfig(notFileSharing) 1
} else {
    set ::test::testConfig(fileSharing) 1
    set ::test::testConfig(notFileSharing) 0
}
file delete -force foo.dir

test macFCmd-1.1 {GetFileFinderAttributes - no file} {
    catch {file delete -force foo.file}
    list [catch {file attributes foo.file -creator} msg] $msg
} {1 {couldn't get attributes for file ":foo.file": no such file or directory}}
test macFCmd-1.2 {GetFileFinderAttributes - creator} {
    catch {file delete -force foo.file}
    catch {close [open foo.file w]}
    list [catch {file attributes foo.file -creator} msg] $msg [file delete -force foo.file]

} {0 {MPW } {}}
test macFCmd-1.3 {GetFileFinderAttributes - type} {
    catch {file delete -force foo.file}
    catch {close [open foo.file w]}
    list [catch {file attributes foo.file -type} msg] $msg [file delete -force foo.file]

} {0 TEXT {}}
test macFCmd-1.4 {GetFileFinderAttributes - not hidden} {
    catch {file delete -force foo.file}
    catch {close [open foo.file w]}
    list [catch {file attributes foo.file -hidden} msg] $msg [file delete -force foo.file]

} {0 0 {}}
test macFCmd-1.5 {GetFileFinderAttributes - hidden} {
    catch {file delete -force foo.file}
    catch {close [open foo.file w]}
    file attributes foo.file -hidden 1
    list [catch {file attributes foo.file -hidden} msg] $msg [file delete -force foo.file]

} {0 1 {}}
test macFCmd-1.6 {GetFileFinderAttributes - folder creator} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -creator} msg] $msg [file delete -force foo.dir]

} {0 Fldr {}}
test macFCmd-1.7 {GetFileFinderAttributes - folder type} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -type} msg] $msg [file delete -force foo.dir]

} {0 Fldr {}}
test macFCmd-1.8 {GetFileFinderAttributes - folder hidden} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -hidden} msg] $msg [file delete -force foo.dir]

} {0 0 {}}

test macFCmd-2.1 {GetFileReadOnly - bad file} {
    catch {file delete -force foo.file}
    list [catch {file attributes foo.file -readonly} msg] $msg
} {1 {couldn't get attributes for file ":foo.file": no such file or directory}}
test macFCmd-2.2 {GetFileReadOnly - file not read only} {
    catch {file delete -force foo.file}
    close [open foo.file w]
    list [catch {file attributes foo.file -readonly} msg] $msg [file delete -force foo.file]

} {0 0 {}}
test macFCmd-2.3 {GetFileReadOnly - file read only} {
    catch {file delete -force foo.file}
    close [open foo.file w]
    file attributes foo.file -readonly 1
    list [catch {file attributes foo.file -readonly} msg] $msg [file delete -force foo.file]

} {0 1 {}}
test macFCmd-2.4 {GetFileReadOnly - directory not read only} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -readonly} msg] $msg [file delete -force foo.dir]

} {0 0 {}}
test macFCmd-2.5 {GetFileReadOnly - directory read only} {fileSharing} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    file attributes foo.dir -readonly 1
    list [catch {file attributes foo.dir -readonly} msg] $msg [file delete -force foo.dir]

} {0 1 {}}

test macFCmd-3.1 {SetFileFinderAttributes - bad file} {
    catch {file delete -force foo.file}
    list [catch {file attributes foo.file -creator FOOO} msg] $msg
} {1 {couldn't set attributes for file ":foo.file": no such file or directory}}
test macFCmd-3.2 {SetFileFinderAttributes - creator} {
    catch {file delete -force foo.file}
    close [open foo.file w]

    list [catch {file attributes foo.file -creator FOOO} msg] $msg [file attributes foo.file -creator] [file delete -force foo.file]
} {0 {} FOOO {}}
test macFCmd-3.3 {SetFileFinderAttributes - bad creator} {
    catch {file delete -force foo.file}
    close [open foo.file w]
    list [catch {file attributes foo.file -creator 0} msg] $msg [file delete -force foo.file]

} {1 {expected Macintosh OS type but got "0"} {}}
test macFCmd-3.4 {SetFileFinderAttributes - hidden} {
    catch {file delete -force foo.file}
    close [open foo.file w]

    list [catch {file attributes foo.file -hidden 1} msg] $msg [file attributes foo.file -hidden] [file delete -force foo.file]
} {0 {} 1 {}}
test macFCmd-3.5 {SetFileFinderAttributes - type} {
    catch {file delete -force foo.file}
    close [open foo.file w]

    list [catch {file attributes foo.file -type FOOO} msg] $msg [file attributes foo.file -type] [file delete -force foo.file]
} {0 {} FOOO {}}
test macFCmd-3.6 {SetFileFinderAttributes - bad type} {
    catch {file delete -force foo.file}
    close [open foo.file w]
    list [catch {file attributes foo.file -type 0} msg] $msg [file delete -force foo.file]

} {1 {expected Macintosh OS type but got "0"} {}}
test macFCmd-3.7 {SetFileFinderAttributes - directory} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -creator FOOO} msg] $msg [file delete -force foo.dir]

} {1 {cannot set -creator: ":foo.dir" is a directory} {}}

test macFCmd-4.1 {SetFileReadOnly - bad file} {
    catch {file delete -force foo.file}
    list [catch {file attributes foo.file -readonly 1} msg] $msg
} {1 {couldn't set attributes for file ":foo.file": no such file or directory}}
test macFCmd-4.2 {SetFileReadOnly - file not readonly} {
    catch {file delete -force foo.file}
    close [open foo.file w]

    list [catch {file attributes foo.file -readonly 0} msg] $msg [file attributes foo.file -readonly] [file delete -force foo.file]
} {0 {} 0 {}}
test macFCmd-4.3 {SetFileReadOnly - file readonly} {
    catch {file delete -force foo.file}
    close [open foo.file w]

    list [catch {file attributes foo.file -readonly 1} msg] $msg [file attributes foo.file -readonly] [file delete -force foo.file]
} {0 {} 1 {}}
test macFCmd-4.4 {SetFileReadOnly - directory not readonly} {fileSharing} {

    catch {file delete -force foo.dir}
    file mkdir foo.dir

    list [catch {file attributes foo.dir -readonly 0} msg] $msg [file attributes foo.dir -readonly] [file delete -force foo.dir]
} {0 {} 0 {}}
test macFCmd-4.5 {SetFileReadOnly - directory not readonly} {notFileSharing} {

    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -readonly 0} msg] $msg [file delete -force foo.dir]

} {1 {cannot set a directory to read-only when File Sharing is turned off} {}}
test macFCmd-4.6 {SetFileReadOnly - directory readonly} {fileSharing} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir

    list [catch {file attributes foo.dir -readonly 1} msg] $msg [file attributes foo.dir -readonly] [file delete -force foo.dir]
} {0 {} 1 {}}
test macFCmd-4.7 {SetFileReadOnly - directory readonly} {notFileSharing} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -readonly 1} msg] $msg [file delete -force foo.dir]

} {1 {cannot set a directory to read-only when File Sharing is turned off} {}}

# cleanup
::test::cleanupTests
return

















|


<
<
<
<
<
|






|
|

|
|



|



|


|
>

|


|
>

|


|
>

|



|
>

|


|
>

|


|
>

|


|
>


|



|


|
>

|



|
>

|


|
>

|



|
>


|



|


>
|

|


|
>

|


>
|

|


>
|

|


|
>

|


|
>


|



|


>
|

|


>
|

|
>


>
|

|
>


|
>

|


>
|

|


|
>



|


>
>
>
>
>
>
>
>
>
>
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
#
# 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.
#
# RCS: @(#) $Id: macFCmd.test,v 1.1.2.4 1999/03/23 20:06:40 hershey Exp $
#






if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {file delete -force foo.dir}
file mkdir foo.dir
if {[catch {file attributes foo.dir -readonly 1}]} {
    set ::tcltest::testConfig(fileSharing) 0
    set ::tcltest::testConfig(notFileSharing) 1
} else {
    set ::tcltest::testConfig(fileSharing) 1
    set ::tcltest::testConfig(notFileSharing) 0
}
file delete -force foo.dir

test macFCmd-1.1 {GetFileFinderAttributes - no file} {macOnly} {
    catch {file delete -force foo.file}
    list [catch {file attributes foo.file -creator} msg] $msg
} {1 {couldn't get attributes for file ":foo.file": no such file or directory}}
test macFCmd-1.2 {GetFileFinderAttributes - creator} {macOnly} {
    catch {file delete -force foo.file}
    catch {close [open foo.file w]}
    list [catch {file attributes foo.file -creator} msg] $msg \
	    [file delete -force foo.file]
} {0 {MPW } {}}
test macFCmd-1.3 {GetFileFinderAttributes - type} {macOnly} {
    catch {file delete -force foo.file}
    catch {close [open foo.file w]}
    list [catch {file attributes foo.file -type} msg] $msg \
	    [file delete -force foo.file]
} {0 TEXT {}}
test macFCmd-1.4 {GetFileFinderAttributes - not hidden} {macOnly} {
    catch {file delete -force foo.file}
    catch {close [open foo.file w]}
    list [catch {file attributes foo.file -hidden} msg] $msg \
	    [file delete -force foo.file]
} {0 0 {}}
test macFCmd-1.5 {GetFileFinderAttributes - hidden} {macOnly} {
    catch {file delete -force foo.file}
    catch {close [open foo.file w]}
    file attributes foo.file -hidden 1
    list [catch {file attributes foo.file -hidden} msg] $msg \
	    [file delete -force foo.file]
} {0 1 {}}
test macFCmd-1.6 {GetFileFinderAttributes - folder creator} {macOnly} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -creator} msg] $msg \
	    [file delete -force foo.dir]
} {0 Fldr {}}
test macFCmd-1.7 {GetFileFinderAttributes - folder type} {macOnly} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -type} msg] $msg \
	    [file delete -force foo.dir]
} {0 Fldr {}}
test macFCmd-1.8 {GetFileFinderAttributes - folder hidden} {macOnly} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -hidden} msg] $msg \
	    [file delete -force foo.dir]
} {0 0 {}}

test macFCmd-2.1 {GetFileReadOnly - bad file} {macOnly} {
    catch {file delete -force foo.file}
    list [catch {file attributes foo.file -readonly} msg] $msg
} {1 {couldn't get attributes for file ":foo.file": no such file or directory}}
test macFCmd-2.2 {GetFileReadOnly - file not read only} {macOnly} {
    catch {file delete -force foo.file}
    close [open foo.file w]
    list [catch {file attributes foo.file -readonly} msg] $msg \
	    [file delete -force foo.file]
} {0 0 {}}
test macFCmd-2.3 {GetFileReadOnly - file read only} {macOnly} {
    catch {file delete -force foo.file}
    close [open foo.file w]
    file attributes foo.file -readonly 1
    list [catch {file attributes foo.file -readonly} msg] $msg \
	    [file delete -force foo.file]
} {0 1 {}}
test macFCmd-2.4 {GetFileReadOnly - directory not read only} {macOnly} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -readonly} msg] $msg \
	    [file delete -force foo.dir]
} {0 0 {}}
test macFCmd-2.5 {GetFileReadOnly - directory read only} {macOnly fileSharing} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    file attributes foo.dir -readonly 1
    list [catch {file attributes foo.dir -readonly} msg] $msg \
	    [file delete -force foo.dir]
} {0 1 {}}

test macFCmd-3.1 {SetFileFinderAttributes - bad file} {macOnly} {
    catch {file delete -force foo.file}
    list [catch {file attributes foo.file -creator FOOO} msg] $msg
} {1 {couldn't set attributes for file ":foo.file": no such file or directory}}
test macFCmd-3.2 {SetFileFinderAttributes - creator} {macOnly} {
    catch {file delete -force foo.file}
    close [open foo.file w]
    list [catch {file attributes foo.file -creator FOOO} msg] $msg \
	    [file attributes foo.file -creator] [file delete -force foo.file]
} {0 {} FOOO {}}
test macFCmd-3.3 {SetFileFinderAttributes - bad creator} {macOnly} {
    catch {file delete -force foo.file}
    close [open foo.file w]
    list [catch {file attributes foo.file -creator 0} msg] $msg \
	    [file delete -force foo.file]
} {1 {expected Macintosh OS type but got "0"} {}}
test macFCmd-3.4 {SetFileFinderAttributes - hidden} {macOnly} {
    catch {file delete -force foo.file}
    close [open foo.file w]
    list [catch {file attributes foo.file -hidden 1} msg] $msg \
	    [file attributes foo.file -hidden] [file delete -force foo.file]
} {0 {} 1 {}}
test macFCmd-3.5 {SetFileFinderAttributes - type} {macOnly} {
    catch {file delete -force foo.file}
    close [open foo.file w]
    list [catch {file attributes foo.file -type FOOO} msg] $msg \
	    [file attributes foo.file -type] [file delete -force foo.file]
} {0 {} FOOO {}}
test macFCmd-3.6 {SetFileFinderAttributes - bad type} {macOnly} {
    catch {file delete -force foo.file}
    close [open foo.file w]
    list [catch {file attributes foo.file -type 0} msg] $msg \
	    [file delete -force foo.file]
} {1 {expected Macintosh OS type but got "0"} {}}
test macFCmd-3.7 {SetFileFinderAttributes - directory} {macOnly} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -creator FOOO} msg] \
	    $msg [file delete -force foo.dir]
} {1 {cannot set -creator: ":foo.dir" is a directory} {}}

test macFCmd-4.1 {SetFileReadOnly - bad file} {macOnly} {
    catch {file delete -force foo.file}
    list [catch {file attributes foo.file -readonly 1} msg] $msg
} {1 {couldn't set attributes for file ":foo.file": no such file or directory}}
test macFCmd-4.2 {SetFileReadOnly - file not readonly} {macOnly} {
    catch {file delete -force foo.file}
    close [open foo.file w]
    list [catch {file attributes foo.file -readonly 0} msg] \
	    $msg [file attributes foo.file -readonly] [file delete -force foo.file]
} {0 {} 0 {}}
test macFCmd-4.3 {SetFileReadOnly - file readonly} {macOnly} {
    catch {file delete -force foo.file}
    close [open foo.file w]
    list [catch {file attributes foo.file -readonly 1} msg] \
	    $msg [file attributes foo.file -readonly] [file delete -force foo.file]
} {0 {} 1 {}}
test macFCmd-4.4 {SetFileReadOnly - directory not readonly} \
	{macOnly fileSharing} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -readonly 0} msg] \
	    $msg [file attributes foo.dir -readonly] [file delete -force foo.dir]
} {0 {} 0 {}}
test macFCmd-4.5 {SetFileReadOnly - directory not readonly} \
	{macOnly notFileSharing} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -readonly 0} msg] $msg \
	    [file delete -force foo.dir]
} {1 {cannot set a directory to read-only when File Sharing is turned off} {}}
test macFCmd-4.6 {SetFileReadOnly - directory readonly} {macOnly fileSharing} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -readonly 1} msg] $msg \
	    [file attributes foo.dir -readonly] [file delete -force foo.dir]
} {0 {} 1 {}}
test macFCmd-4.7 {SetFileReadOnly - directory readonly} {macOnly notFileSharing} {
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -readonly 1} msg] $msg \
	    [file delete -force foo.dir]
} {1 {cannot set a directory to read-only when File Sharing is turned off} {}}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/misc.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
..
55
56
57
58
59
60
61
62
63
64










# Copyright (c) 1992-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.
#
# RCS: @(#) $Id: misc.test,v 1.1.2.3 1999/03/11 18:49:55 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test misc-1.1 {error in variable ref. in command in array reference} {
    proc tstProc {} {
	global a
    
................................................................................
    while compiling
"set tst $a([winfo name "
    (compiling body of proc "tstProc", line 4)
    invoked from within
"tstProc"}}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
..
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
# Copyright (c) 1992-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.
#
# RCS: @(#) $Id: misc.test,v 1.1.2.4 1999/03/23 20:06:40 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test misc-1.1 {error in variable ref. in command in array reference} {
    proc tstProc {} {
	global a
    
................................................................................
    while compiling
"set tst $a([winfo name "
    (compiling body of proc "tstProc", line 4)
    invoked from within
"tstProc"}}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/msgcat.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
298
299
300
301
302
303
304
305
306
307










#
# Copyright (c) 1998 Mark Harrison.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: msgcat.test,v 1.1.2.4 1999/03/11 18:49:55 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {package require msgcat 1.0}]} {
    if {[info exist msgcat1]} {
	catch {puts "Cannot load msgcat 1.0 package"}
	return
................................................................................
    file delete [string tolower [file join msgdir $l.msg]]
}

# Clean out the msg catalogs
::msgcat::mclocale $oldlocale
file delete msgdir

::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
#
# Copyright (c) 1998 Mark Harrison.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: msgcat.test,v 1.1.2.5 1999/03/23 20:06:41 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {package require msgcat 1.0}]} {
    if {[info exist msgcat1]} {
	catch {puts "Cannot load msgcat 1.0 package"}
	return
................................................................................
    file delete [string tolower [file join msgdir $l.msg]]
}

# Clean out the msg catalogs
::msgcat::mclocale $oldlocale
file delete msgdir

::tcltest::cleanupTests
return











Changes to tests/namespace-old.test.

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
...
843
844
845
846
847
848
849
850
851
852










# Copyright (c) 1997 Sun Microsystems, Inc.
# 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.
#
# RCS: @(#) $Id: namespace-old.test,v 1.1.2.3 1999/03/11 18:49:56 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Clear out any namespaces called test_ns_*
catch {eval namespace delete [namespace children :: test_ns_*]}

test namespace-old-1.1 {usage for "namespace" command} {
................................................................................
catch {unset msg}
catch {unset x}
catch {unset test_ns_var_global}
catch {unset cmd}
eval namespace delete [namespace children :: test_ns_*]

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
...
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
# Copyright (c) 1997 Sun Microsystems, Inc.
# 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.
#
# RCS: @(#) $Id: namespace-old.test,v 1.1.2.4 1999/03/23 20:06:41 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Clear out any namespaces called test_ns_*
catch {eval namespace delete [namespace children :: test_ns_*]}

test namespace-old-1.1 {usage for "namespace" command} {
................................................................................
catch {unset msg}
catch {unset x}
catch {unset test_ns_var_global}
catch {unset cmd}
eval namespace delete [namespace children :: test_ns_*]

# cleanup
::tcltest::cleanupTests
return











Changes to tests/namespace.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
....
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104










#
# 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.
#
# RCS: @(#) $Id: namespace.test,v 1.1.2.3 1999/03/11 18:49:56 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Clear out any namespaces called test_ns_*
catch {eval namespace delete [namespace children :: test_ns_*]}

test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} {
................................................................................

# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
eval namespace delete [namespace children :: test_ns_*]
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
....
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
#
# 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.
#
# RCS: @(#) $Id: namespace.test,v 1.1.2.4 1999/03/23 20:06:42 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Clear out any namespaces called test_ns_*
catch {eval namespace delete [namespace children :: test_ns_*]}

test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} {
................................................................................

# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
eval namespace delete [namespace children :: test_ns_*]
::tcltest::cleanupTests
return











Changes to tests/obj.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
525
526
527
528
529
530
531
532
533
534










#
# 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.
#
# RCS: @(#) $Id: obj.test,v 1.1.2.3 1999/03/11 18:49:57 hershey Exp $

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} {
    set r 1
    foreach {t} {list boolean cmdName bytecode string int double} {
        set first [string first $t [testobj types]]
................................................................................
    lappend result [testobj refcount 1]
    lappend result [testobj refcount 2]
} {{} 1024 1024 int 4 4 0 boolean 3 2}

testobj freeallvars

# cleanup
::test::cleanupTests
return

















|







|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
#
# 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.
#
# RCS: @(#) $Id: obj.test,v 1.1.2.4 1999/03/23 20:06:42 hershey Exp $

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} {
    set r 1
    foreach {t} {list boolean cmdName bytecode string int double} {
        set first [string first $t [testobj types]]
................................................................................
    lappend result [testobj refcount 1]
    lappend result [testobj refcount 2]
} {{} 1024 1024 int 4 4 0 boolean 3 2}

testobj freeallvars

# cleanup
::tcltest::cleanupTests
return











Changes to tests/opt.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
270
271
272
273
274
275
276
277
278
279










# Copyright (c) 1991-1993 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: opt.test,v 1.1.2.3 1999/03/11 18:49:58 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# the package we are going to test
package require opt 0.4.1

# we are using implementation specifics to test the package
................................................................................
    set key [::tcl::OptKeyRegister {{args -list {a b c} "args..."}}]
    ::tcl::OptKeyParse $key {}
    ::tcl::OptKeyDelete $key
    set args
} {a b c}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
# Copyright (c) 1991-1993 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: opt.test,v 1.1.2.4 1999/03/23 20:06:43 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# the package we are going to test
package require opt 0.4.1

# we are using implementation specifics to test the package
................................................................................
    set key [::tcl::OptKeyRegister {{args -list {a b c} "args..."}}]
    ::tcl::OptKeyParse $key {}
    ::tcl::OptKeyDelete $key
    set args
} {a b c}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/osa.test.

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










#
# 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.
#
# RCS: @(#) $Id: osa.test,v 1.1.2.3 1999/03/11 18:49:58 hershey Exp $

# This command only runs on the Macintosh, only run the test if we
# can load the command
if {$tcl_platform(platform) != "macintosh"} {
    puts "skipping: Mac only tests..."
    return
}
if {[info commands AppleScript] == ""} {
    puts "couldn't find AppleScript command..."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}




test osa-1.1 {Tcl_OSAComponentCmd} {
    list [catch AppleScript msg] $msg
} {1 {wrong # args: should be "AppleScript option ?arg ...?"}}
test osa-1.2 {Tcl_OSAComponentCmd} {
    list [catch {AppleScript x} msg] $msg
} {1 {bad option "x": should be compile, decompile, delete, execute, info, load, run or store}}

test osa-1.3 {TclOSACompileCmd} {
    list [catch {AppleScript compile} msg] $msg
} {1 {wrong # args: should be "AppleScript compile ?options? code"}}

# cleanup
::test::cleanupTests
return

















|

<
<
<
<
<
<
<
<
<
<
<
|



>
>
>
|


|



|




|


>
>
>
>
>
>
>
>
>
>
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
#
# 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.
#
# RCS: @(#) $Id: osa.test,v 1.1.2.4 1999/03/23 20:06:44 hershey Exp $












if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Only run the test if we can load the AppleScript command
set ::tcltest::testConfig(appleScript) [expr {[info commands AppleScript] != ""}]

test osa-1.1 {Tcl_OSAComponentCmd} {macOnly appleScript} {
    list [catch AppleScript msg] $msg
} {1 {wrong # args: should be "AppleScript option ?arg ...?"}}
test osa-1.2 {Tcl_OSAComponentCmd} {macOnly appleScript} {
    list [catch {AppleScript x} msg] $msg
} {1 {bad option "x": should be compile, decompile, delete, execute, info, load, run or store}}

test osa-1.3 {TclOSACompileCmd} {macOnly appleScript} {
    list [catch {AppleScript compile} msg] $msg
} {1 {wrong # args: should be "AppleScript compile ?options? code"}}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/parse.test.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
...
714
715
716
717
718
719
720
721
722
723
724










#
# 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.
#
# RCS: @(#) $Id: parse.test,v 1.1.2.8 1999/03/11 18:49:58 hershey Exp $

if {[info commands testparser] == {}} {
    puts "This application hasn't been compiled with the \"testparser\""
    puts "command, so I can't test the Tcl parser."
    return 
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test parse-1.1 {Tcl_ParseCommand procedure, computing string length} {
    testparser [bytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-1.2 {Tcl_ParseCommand procedure, computing string length} {
................................................................................
} 0
test parse-15.57 {CommandComplete procedure} {
    info complete "# Comment should be complete command"
} 1

# cleanup
catch {unset a}
::test::cleanupTests
return


















|







|







 







|



>
>
>
>
>
>
>
>
>
>
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
...
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
#
# 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.
#
# RCS: @(#) $Id: parse.test,v 1.1.2.9 1999/03/23 20:06:44 hershey Exp $

if {[info commands testparser] == {}} {
    puts "This application hasn't been compiled with the \"testparser\""
    puts "command, so I can't test the Tcl parser."
    return 
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test parse-1.1 {Tcl_ParseCommand procedure, computing string length} {
    testparser [bytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-1.2 {Tcl_ParseCommand procedure, computing string length} {
................................................................................
} 0
test parse-15.57 {CommandComplete procedure} {
    info complete "# Comment should be complete command"
} 1

# cleanup
catch {unset a}
::tcltest::cleanupTests
return












Changes to tests/parseExpr.test.

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
...
616
617
618
619
620
621
622
623
624
625










#
# 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.
#
# RCS: @(#) $Id: parseExpr.test,v 1.1.2.2 1999/03/11 18:49:59 hershey Exp $

# Note that the Tcl expression parser (tclParseExpr.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
# of "<<" are integers.

if {[info commands testexprparser] == {}} {
    puts "This application hasn't been compiled with the \"testexprparser\""
    puts "command, so I can't test the Tcl expression parser."
    return 
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} {
    testexprparser [bytestring "1+2\0 +3"] -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} {
................................................................................
} {- {} 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 13 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 9 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 5 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 {}}

test parse-16.1 {LogSyntaxError procedure, error in expr longer than 60 chars} {
    list [catch {testexprparser {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1} msg] $msg
} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012"}}

# cleanup
::test::cleanupTests
return

















|












|







 







|


>
>
>
>
>
>
>
>
>
>
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
...
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
#
# 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.
#
# RCS: @(#) $Id: parseExpr.test,v 1.1.2.3 1999/03/23 20:06:45 hershey Exp $

# Note that the Tcl expression parser (tclParseExpr.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
# of "<<" are integers.

if {[info commands testexprparser] == {}} {
    puts "This application hasn't been compiled with the \"testexprparser\""
    puts "command, so I can't test the Tcl expression parser."
    return 
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} {
    testexprparser [bytestring "1+2\0 +3"] -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} {
................................................................................
} {- {} 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 13 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 9 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 5 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 {}}

test parse-16.1 {LogSyntaxError procedure, error in expr longer than 60 chars} {
    list [catch {testexprparser {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1} msg] $msg
} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012"}}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/parseOld.test.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
526
527
528
529
530
531
532
533
534
535










# 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.
#
# RCS: @(#) $Id: parseOld.test,v 1.1.2.2 1999/03/11 18:50:00 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc fourArgs {a b c d} {
    global arg1 arg2 arg3 arg4
    set arg1 $a
    set arg2 $b
................................................................................
    info complete "xyz \[abc \{abc\]"
} {0}
test parseOld-15.5 {TclScriptEnd procedure} {
    info complete "xyz \[abc"
} {0}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
# 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.
#
# RCS: @(#) $Id: parseOld.test,v 1.1.2.3 1999/03/23 20:06:45 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc fourArgs {a b c d} {
    global arg1 arg2 arg3 arg4
    set arg1 $a
    set arg2 $b
................................................................................
    info complete "xyz \[abc \{abc\]"
} {0}
test parseOld-15.5 {TclScriptEnd procedure} {
    info complete "xyz \[abc"
} {0}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/pid.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
..
48
49
50
51
52
53
54
55
56
57
58










# Copyright (c) 1991-1993 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: pid.test,v 1.1.2.3 1999/03/11 18:50:00 hershey Exp $

# If pid is not defined just return with no error
# Some platforms may not have the pid command implemented
if {[info commands pid] == ""} {
    puts "pid is not implemented for this machine"
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {removeFile test1}

test pid-1.1 {pid command} {
    regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
................................................................................
    list [catch {pid a b} msg] $msg
} {1 {wrong # args: should be "pid ?channelId?"}}
test pid-1.5 {pid command} {
    list [catch {pid gorp} msg] $msg
} {1 {can not find channel named "gorp"}}

# cleanup
catch {::test::removeFile test1}
::test::cleanupTests
return

















|








|







 







|
|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
..
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
# Copyright (c) 1991-1993 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: pid.test,v 1.1.2.4 1999/03/23 20:06:46 hershey Exp $

# If pid is not defined just return with no error
# Some platforms may not have the pid command implemented
if {[info commands pid] == ""} {
    puts "pid is not implemented for this machine"
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {removeFile test1}

test pid-1.1 {pid command} {
    regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
................................................................................
    list [catch {pid a b} msg] $msg
} {1 {wrong # args: should be "pid ?channelId?"}}
test pid-1.5 {pid command} {
    list [catch {pid gorp} msg] $msg
} {1 {can not find channel named "gorp"}}

# cleanup
catch {::tcltest::removeFile test1}
::tcltest::cleanupTests
return











Changes to tests/pkg.test.

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
...
632
633
634
635
636
637
638
639
640
641










#
# 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.
#
# RCS: @(#) $Id: pkg.test,v 1.1.2.5 1999/03/12 19:51:31 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Do all this in a slave interp to avoid garbaging the
# package list
set i [interp create]
interp eval $i [list set argv $argv]
interp eval $i [list source [file join $::test::testsDir defs.tcl]]
interp eval $i {

eval package forget [package names]
set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
set auto_path ""
................................................................................
package unknown $oldPkgUnknown
concat

}

# cleanup
interp delete $i
::test::cleanupTests
return

















|

|







|







 







|


>
>
>
>
>
>
>
>
>
>
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
...
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
#
# 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.
#
# RCS: @(#) $Id: pkg.test,v 1.1.2.6 1999/03/23 20:06:46 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Do all this in a slave interp to avoid garbaging the
# package list
set i [interp create]
interp eval $i [list set argv $argv]
interp eval $i [list source [file join $::tcltest::testsDir defs.tcl]]
interp eval $i {

eval package forget [package names]
set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
set auto_path ""
................................................................................
package unknown $oldPkgUnknown
concat

}

# cleanup
interp delete $i
::tcltest::cleanupTests
return











Changes to tests/pkgMkIndex.test.

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










#
# 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.
#
# RCS: @(#) $Id: pkgMkIndex.test,v 1.4.2.4 1999/03/12 22:32:38 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# temporarily copy the pkg and pkg1 dirs from testsDir to tmpDir
if {"$::test::testsDir" != "$::test::tmpDir"} {
    set origPkgDir [file join $::test::testsDir pkg]
    set newPkgDir [file join $::test::tmpDir pkg]
    if {![catch {file copy $origPkgDir $newPkgDir}]} {
	set removePkgDir 1
    }
    if {![catch {file copy "${origPkgDir}1" "${newPkgDir}1"}]} {
	set removePkg1Dir 1
    }
}

# Add the pkg1 directory to auto_path, so that its packages can be found.
# packages in pkg1 are used to test indexing of packages in pkg.
# Make sure that the path to pkg1 is absolute.

set oldDir [pwd]
lappend auto_path [file join $::test::tmpDir pkg1]

namespace eval pkgtest {
    # Namespace for procs we can discard
}

# pkgtest::parseArgs --
#
................................................................................
source [file join pkg pkg2_b.tcl]}} {pkg5:1.0 {source [file join pkg pkg5.tcl]}}}"

test pkgMkIndex-9.1 {circular packages} {
    pkgtest::runIndex pkg circ1.tcl circ2.tcl circ3.tcl
} {0 {{circ1:1.0 {tclPkgSetup {circ1.tcl source {::circ1::c1-1 ::circ1::c1-2 ::circ1::c1-3 ::circ1::c1-4}}}} {circ2:1.0 {tclPkgSetup {circ2.tcl source {::circ2::c2-1 ::circ2::c2-2}}}} {circ3:1.0 {tclPkgSetup {circ3.tcl source ::circ3::c3-1}}}}}

# Try to find one of the DLLs in the dltest directory
set x [file join $::test::testsDir ../unix/dltest/pkga[info sharedlibextension]]
if {[file exists $x]} {
    file copy -force $x pkg
    test pkgMkIndex-10.1 {package in DLL and script} {
	pkgtest::runIndex pkg pkga[info sharedlibextension] pkga.tcl
    } "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}"
    test pkgMkIndex-10.2 {package in DLL hidden by -load} {
	pkgtest::runIndex -load Pkg* -- pkg pkga[info sharedlibextension]
................................................................................
    } {0 {}}
} else {
    puts "Skipping pkgMkIndex-10.1 (index of DLL and script)"
}

# cleanup
namespace delete pkgtest
cd $::test::tmpDir
if {[info exists removePkgDir]} {
    # strange error deleting the pkg dir only once--needs be done twice!
    catch {file delete -force $newPkgDir}
    catch {file delete -force $newPkgDir}
}
if {[info exists removePkg1Dir]} {
    catch {file delete -force "${newPkgDir}1"}
}
::test::cleanupTests
return
















|

|




|
|
|













|







 







|







 







|








|

>
>
>
>
>
>
>
>
>
>
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
...
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
#
# 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.
#
# RCS: @(#) $Id: pkgMkIndex.test,v 1.4.2.5 1999/03/23 20:06:47 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# temporarily copy the pkg and pkg1 dirs from testsDir to tmpDir
if {"$::tcltest::testsDir" != "$::tcltest::tmpDir"} {
    set origPkgDir [file join $::tcltest::testsDir pkg]
    set newPkgDir [file join $::tcltest::tmpDir pkg]
    if {![catch {file copy $origPkgDir $newPkgDir}]} {
	set removePkgDir 1
    }
    if {![catch {file copy "${origPkgDir}1" "${newPkgDir}1"}]} {
	set removePkg1Dir 1
    }
}

# Add the pkg1 directory to auto_path, so that its packages can be found.
# packages in pkg1 are used to test indexing of packages in pkg.
# Make sure that the path to pkg1 is absolute.

set oldDir [pwd]
lappend auto_path [file join $::tcltest::tmpDir pkg1]

namespace eval pkgtest {
    # Namespace for procs we can discard
}

# pkgtest::parseArgs --
#
................................................................................
source [file join pkg pkg2_b.tcl]}} {pkg5:1.0 {source [file join pkg pkg5.tcl]}}}"

test pkgMkIndex-9.1 {circular packages} {
    pkgtest::runIndex pkg circ1.tcl circ2.tcl circ3.tcl
} {0 {{circ1:1.0 {tclPkgSetup {circ1.tcl source {::circ1::c1-1 ::circ1::c1-2 ::circ1::c1-3 ::circ1::c1-4}}}} {circ2:1.0 {tclPkgSetup {circ2.tcl source {::circ2::c2-1 ::circ2::c2-2}}}} {circ3:1.0 {tclPkgSetup {circ3.tcl source ::circ3::c3-1}}}}}

# Try to find one of the DLLs in the dltest directory
set x [file join $::tcltest::testsDir ../unix/dltest/pkga[info sharedlibextension]]
if {[file exists $x]} {
    file copy -force $x pkg
    test pkgMkIndex-10.1 {package in DLL and script} {
	pkgtest::runIndex pkg pkga[info sharedlibextension] pkga.tcl
    } "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}"
    test pkgMkIndex-10.2 {package in DLL hidden by -load} {
	pkgtest::runIndex -load Pkg* -- pkg pkga[info sharedlibextension]
................................................................................
    } {0 {}}
} else {
    puts "Skipping pkgMkIndex-10.1 (index of DLL and script)"
}

# cleanup
namespace delete pkgtest
cd $::tcltest::tmpDir
if {[info exists removePkgDir]} {
    # strange error deleting the pkg dir only once--needs be done twice!
    catch {file delete -force $newPkgDir}
    catch {file delete -force $newPkgDir}
}
if {[info exists removePkg1Dir]} {
    catch {file delete -force "${newPkgDir}1"}
}
::tcltest::cleanupTests
return










Changes to tests/platform.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24










# 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.
#
# RCS: @(#) 

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test platform-1.1 {TclpSetVariables: tcl_platform} {
    lsort [array names tcl_platform]
} {byteOrder machine os osVersion platform user}

# cleanup
::test::cleanupTests
return
















|








|

>
>
>
>
>
>
>
>
>
>
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
# 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.
#
# RCS: @(#) 

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test platform-1.1 {TclpSetVariables: tcl_platform} {
    lsort [array names tcl_platform]
} {byteOrder machine os osVersion platform user}

# cleanup
::tcltest::cleanupTests
return










Changes to tests/proc-old.test.

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
...
503
504
505
506
507
508
509
510
511
512










# Copyright (c) 1991-1993 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: proc-old.test,v 1.1.2.3 1999/03/11 18:50:02 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {rename t1 ""}
catch {rename foo ""}

proc tproc {} {return a; return b}
................................................................................
    }
    t1 1
} 20

# cleanup
catch {rename t1 ""}
catch {rename foo ""}
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
...
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
# Copyright (c) 1991-1993 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: proc-old.test,v 1.1.2.4 1999/03/23 20:06:47 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {rename t1 ""}
catch {rename foo ""}

proc tproc {} {return a; return b}
................................................................................
    }
    t1 1
} 20

# cleanup
catch {rename t1 ""}
catch {rename foo ""}
::tcltest::cleanupTests
return











Changes to tests/proc.test.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
291
292
293
294
295
296
297
298
299
300










#
# 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.
#
# RCS: @(#) $Id: proc.test,v 1.1.2.4 1999/03/11 18:50:02 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename {} ""}
catch {unset msg}
................................................................................
    catch {rename t ""}
    set result
} {procedure "t": formal parameter "z" has default value inconsistent with precompiled body}

# cleanup
catch {rename p ""}
catch {rename t ""}
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
#
# 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.
#
# RCS: @(#) $Id: proc.test,v 1.1.2.5 1999/03/23 20:06:48 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename {} ""}
catch {unset msg}
................................................................................
    catch {rename t ""}
    set result
} {procedure "t": formal parameter "z" has default value inconsistent with precompiled body}

# cleanup
catch {rename p ""}
catch {rename t ""}
::tcltest::cleanupTests
return











Changes to tests/pwd.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30










# Copyright (c) 1991-1993 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: pwd.test,v 1.1.2.2 1999/03/11 18:50:03 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test pwd-1.1 {simple pwd} {
	catch pwd
} 0
test pwd-1.2 {simple pwd} {
	expr [string length pwd]>0
} 1

# cleanup
::test::cleanupTests
return

















|

|











|


>
>
>
>
>
>
>
>
>
>
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
# Copyright (c) 1991-1993 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: pwd.test,v 1.1.2.3 1999/03/23 20:06:48 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test pwd-1.1 {simple pwd} {
	catch pwd
} 0
test pwd-1.2 {simple pwd} {
	expr [string length pwd]>0
} 1

# cleanup
::tcltest::cleanupTests
return











Changes to tests/reg.test.

3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
889
890
891
892
893
894
895
896
897
898
# 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.
# All rights reserved.
#
# RCS: @(#) $Id: reg.test,v 1.1.2.4 1999/03/23 04:13:53 stanton Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# This file uses some custom procedures, defined below, for regexp regression
# testing.  The name of the procedure indicates the general nature of the
# test:  e for compile error expected, f for match failure expected, m
# for a successful match, and i for a successful match with -indices (used
................................................................................
m  6	&M	 {[0-6][1-2][0-3][0-6][1-6][0-6]}	010010	010010



doing 0 "flush"			;# to flush any leftover complaints

# cleanup
::test::cleanupTests
return







|

|







 







|


3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
889
890
891
892
893
894
895
896
897
898
# 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.
# All rights reserved.
#
# RCS: @(#) $Id: reg.test,v 1.1.2.5 1999/03/23 20:06:49 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# This file uses some custom procedures, defined below, for regexp regression
# testing.  The name of the procedure indicates the general nature of the
# test:  e for compile error expected, f for match failure expected, m
# for a successful match, and i for a successful match with -indices (used
................................................................................
m  6	&M	 {[0-6][1-2][0-3][0-6][1-6][0-6]}	010010	010010



doing 0 "flush"			;# to flush any leftover complaints

# cleanup
::tcltest::cleanupTests
return

Changes to tests/regexp.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
358
359
360
361
362
363
364
365
366
367










# Copyright (c) 1991-1993 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: regexp.test,v 1.1.2.7 1999/03/11 18:50:03 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset foo}
test regexp-1.1 {basic regexp operation} {
    regexp ab*c abbbc
} 1
................................................................................
    for {set i 1} {$i<10} {incr i} {
	regsub -all "BEGIN_TABLE " $filedata "" newfiledata
    }
    set x done
} {done}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
# Copyright (c) 1991-1993 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: regexp.test,v 1.1.2.8 1999/03/23 20:06:49 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset foo}
test regexp-1.1 {basic regexp operation} {
    regexp ab*c abbbc
} 1
................................................................................
    for {set i 1} {$i<10} {incr i} {
	regsub -all "BEGIN_TABLE " $filedata "" newfiledata
    }
    set x done
} {done}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/registry.test.

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










#
# 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.
#
# RCS: @(#) $Id: registry.test,v 1.1.2.5 1999/03/11 18:50:04 hershey Exp $

if {$tcl_platform(platform) != "windows"} {
    puts "skipping: Windows only tests..."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {$::test::testConfig(win32s)} {
    puts "Skipping registry tests under Win32s"
    return
}



set lib [lindex [glob [file join [pwd] [file dirname \
	[info nameofexecutable]] tclreg*.dll]] 0]

if [catch {load $lib registry}] {

    puts "Unable to find the registry package. Skipping registry tests."
    return
}

switch $tcl_platform(os) {
    "Windows NT" {set ::test::testConfig(NT) 1}
    "Windows 95" {set ::test::testConfig(95) 1}
}

# determine the current locale
set old [testlocale all]
if {[testlocale all ""] == "English_United States.1252"} {
    # error messages from registry package are already localized.

    set ::test::testConfig(english) 1
}
testlocale all $old
unset old

set hostname [info hostname]

test registry-1.1 {argument parsing for registry command} {
    list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry option ?arg arg ...?"}}
test registry-1.2 {argument parsing for registry command} {
    list [catch {registry foo} msg] $msg
} {1 {bad option "foo": must be delete, get, keys, set, type, or values}}

test registry-1.3 {argument parsing for registry command} {
    list [catch {registry d} msg] $msg
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}
test registry-1.4 {argument parsing for registry command} {
    list [catch {registry delete} msg] $msg
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}
test registry-1.5 {argument parsing for registry command} {
    list [catch {registry delete foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}

test registry-1.6 {argument parsing for registry command} {
    list [catch {registry g} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}
test registry-1.7 {argument parsing for registry command} {
    list [catch {registry get} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}
test registry-1.8 {argument parsing for registry command} {
    list [catch {registry get foo} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}
test registry-1.9 {argument parsing for registry command} {
    list [catch {registry get foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}

test registry-1.10 {argument parsing for registry command} {
    list [catch {registry k} msg] $msg
} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}
test registry-1.11 {argument parsing for registry command} {
    list [catch {registry keys} msg] $msg
} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}
test registry-1.12 {argument parsing for registry command} {
    list [catch {registry keys foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}

test registry-1.13 {argument parsing for registry command} {
    list [catch {registry s} msg] $msg
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
test registry-1.14 {argument parsing for registry command} {
    list [catch {registry set} msg] $msg
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
test registry-1.15 {argument parsing for registry command} {
    list [catch {registry set foo bar} msg] $msg
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
test registry-1.16 {argument parsing for registry command} {
    list [catch {registry set foo bar baz blat gorp} msg] $msg
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}

test registry-1.17 {argument parsing for registry command} {
    list [catch {registry t} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}
test registry-1.18 {argument parsing for registry command} {
    list [catch {registry type} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}
test registry-1.19 {argument parsing for registry command} {
    list [catch {registry type foo} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}
test registry-1.20 {argument parsing for registry command} {
    list [catch {registry type foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}

test registry-1.21 {argument parsing for registry command} {
    list [catch {registry v} msg] $msg
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}
test registry-1.22 {argument parsing for registry command} {
    list [catch {registry values} msg] $msg
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}
test registry-1.23 {argument parsing for registry command} {
    list [catch {registry values foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}

test registry-2.1 {DeleteKey: bad key} {
    list [catch {registry delete foo} msg] $msg
} {1 {bad root name "foo": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-2.2 {DeleteKey: bad key} {
    list [catch {registry delete HKEY_CLASSES_ROOT} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-2.3 {DeleteKey: bad key} {
    list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-2.4 {DeleteKey: subkey at root level} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry keys HKEY_CLASSES_ROOT TclFoobar
} {}
test registry-2.5 {DeleteKey: subkey below root level} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test
    registry delete HKEY_CLASSES_ROOT\\TclFoobar\\test
    set result [registry keys HKEY_CLASSES_ROOT TclFoobar\\test]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}
test registry-2.6 {DeleteKey: recursive delete} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry keys HKEY_CLASSES_ROOT TclFoobar]
    set result
} {}
test registry-2.7 {DeleteKey: trailing backslashes} {english} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz
    list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar\\} msg] $msg
} {1 {unable to delete key: The configuration registry key is invalid.}}
test registry-2.8 {DeleteKey: failure} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
} {}


test registry-3.1 {DeleteValue} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test1 blort
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test2 blat
    registry delete HKEY_CLASSES_ROOT\\TclFoobar\\baz test1
    set result [registry values HKEY_CLASSES_ROOT\\TclFoobar\\baz]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} test2
test registry-3.2 {DeleteValue: bad key} {english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar test} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-3.3 {DeleteValue: bad value} {english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test2 blort
    set result [list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar test1} msg] $msg]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {1 {unable to delete value "test1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}}


test registry-4.1 {GetKeyNames: bad key} {english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-4.2 {GetKeyNames} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz
    set result [registry keys HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {baz}
test registry-4.3 {GetKeyNames: remote key} {nonPortable english} {
    registry set \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar\\baz
    set result [registry keys \\\\gaspode\\HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {baz}
test registry-4.4 {GetKeyNames: empty key} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry keys HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}
test registry-4.5 {GetKeyNames: patterns} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\foo
    set result [lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {baz blat}
test registry-4.6 {GetKeyNames: names with spaces} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz\ bar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\foo
    set result [lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{baz bar} blat}

test registry-5.1 {GetType} {english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry type HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-5.2 {GetType} {english} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry type HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg
} {1 {unable to get type of value "val1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}}
test registry-5.3 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar none
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} none
test registry-5.4 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} sz
test registry-5.5 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar sz
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} sz
test registry-5.6 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar expand_sz
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} expand_sz
test registry-5.7 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 binary
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} binary
test registry-5.8 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 dword
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} dword
test registry-5.9 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 dword_big_endian
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} dword_big_endian
test registry-5.10 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 link
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} link
test registry-5.11 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar multi_sz
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} multi_sz
test registry-5.12 {GetType} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 resource_list
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} resource_list
test registry-5.13 {GetType: unknown types} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 24
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 24

test registry-6.1 {GetValue} {english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry get HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-6.2 {GetValue} {english} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry get HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg
} {1 {unable to get value "val1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}}
test registry-6.3 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar none
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.4 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.5 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.6 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar expand_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.7 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 binary
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 1
test registry-6.8 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 0x20 dword
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 32
test registry-6.9 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 0x20 dword_big_endian
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 32
test registry-6.10 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 link
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 1
test registry-6.11 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.12 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {foo\ bar baz} multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{foo bar} baz}
test registry-6.13 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {} multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}
test registry-6.14 {GetValue: truncation of multivalues with null elements} {

    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {a {} b} multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} a
test registry-6.15 {GetValue} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 resource_list
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 1
test registry-6.16 {GetValue: unknown types} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 24
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 1

test registry-7.1 {GetValueNames: bad key} {english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry values HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-7.2 {GetValueNames} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar
    set result [registry values HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} baz
test registry-7.3 {GetValueNames} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar1
    registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2
    registry set HKEY_CLASSES_ROOT\\TclFoobar {} foobar3
    set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{} baz blat}
test registry-7.4 {GetValueNames: remote key} {nonPortable english} {
    registry set \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar baz blat
    set result [registry values \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar
    set result
} baz
test registry-7.5 {GetValueNames: empty key} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry values HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}
test registry-7.6 {GetValueNames: patterns} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar1
    registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2
    registry set HKEY_CLASSES_ROOT\\TclFoobar foo foobar3
    set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {baz blat}
test registry-7.7 {GetValueNames: names with spaces} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz\ bar foobar1
    registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2
    registry set HKEY_CLASSES_ROOT\\TclFoobar foo foobar3
    set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{baz bar} blat}

test registry-8.1 {OpenSubKey} {nonPortable english} {
    list [catch {registry keys {\\petrouchka\HKEY_LOCAL_MACHINE}} msg] $msg
} {1 {unable to open key: Access is denied.}}
test registry-8.2 {OpenSubKey} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry keys HKEY_CLASSES_ROOT TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} TclFoobar
test registry-8.3 {OpenSubKey} {english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}

test registry-9.1 {ParseKeyName: bad keys} {
    list [catch {registry values \\} msg] $msg
} "1 {bad key \"\\\": must start with a valid root}"
test registry-9.2 {ParseKeyName: bad keys} {
    list [catch {registry values \\foobar} msg] $msg
} {1 {bad key "\foobar": must start with a valid root}}
test registry-9.3 {ParseKeyName: bad keys} {
    list [catch {registry values \\\\} msg] $msg
} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-9.4 {ParseKeyName: bad keys} {
    list [catch {registry values \\\\\\} msg] $msg
} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-9.5 {ParseKeyName: bad keys} {english} {
    list [catch {registry values \\\\\\HKEY_CLASSES_ROOT} msg] $msg
} {1 {unable to open key: The network address is invalid.}}
test registry-9.6 {ParseKeyName: bad keys} {
    list [catch {registry values \\\\gaspode} msg] $msg
} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-9.7 {ParseKeyName: bad keys} {
    list [catch {registry values foobar} msg] $msg
} {1 {bad root name "foobar": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-9.8 {ParseKeyName: null keys} {
    list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-9.9 {ParseKeyName: null keys} {english} {
    list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar\\baz} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}

test registry-10.1 {RecursiveDeleteKey} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry keys HKEY_CLASSES_ROOT TclFoobar]
    set result
} {}
test registry-10.2 {RecursiveDeleteKey} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3
    set result [registry delete HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test4]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}

test registry-11.1 {SetValue: recursive creation} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat foobar
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar\\baz blat]
} foobar
test registry-11.2 {SetValue: modification} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat foobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat frob
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar\\baz blat]
} frob
test registry-11.3 {SetValue: failure} {nonPortable english} {
    list [catch {registry set {\\petrouchka\HKEY_CLASSES_ROOT\TclFoobar} bar foobar} msg] $msg
} {1 {unable to open key: Access is denied.}}


# cleanup
unset hostname
::test::cleanupTests
return

















|

<
<
<
<
<
|



<
<
<
<
<
>
>
|
|
<
|
>
|
|
|
<
<
<
<







|






|


|



|


|


|



|


|


|


|



|


|


|



|


|


|


|



|


|


|


|



|


|


|



|


|


|


|




|






|






|



|





|








|



|








|



|






|





|






|








|









|



|



|





|





|





|





|





|





|





|





|





|





|






|



|



|





|





|





|





|





|





|





|





|





|





|





|
>





|





|






|



|






|








|





|






|








|









|


|






|




|


|


|


|


|


|


|


|


|



|







|








|




|





|






|


>
>
>
>
>
>
>
>
>
>
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
#
# 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.
#
# RCS: @(#) $Id: registry.test,v 1.1.2.6 1999/03/23 20:06:50 hershey Exp $






if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}






if {$tcl_platform(platform) == "windows"} {
    if [catch {
	set lib [lindex [glob [file join [pwd] [file dirname \
		[info nameofexecutable]] tclreg*.dll]] 0]

	load $lib registry
    }] {
	puts "Unable to find the registry package. Skipping registry tests."
	return
    }




}

# determine the current locale
set old [testlocale all]
if {[testlocale all ""] == "English_United States.1252"} {
    # error messages from registry package are already localized.

    set ::tcltest::testConfig(english) 1
}
testlocale all $old
unset old

set hostname [info hostname]

test registry-1.1 {argument parsing for registry command} {pcOnly} {
    list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry option ?arg arg ...?"}}
test registry-1.2 {argument parsing for registry command} {pcOnly} {
    list [catch {registry foo} msg] $msg
} {1 {bad option "foo": must be delete, get, keys, set, type, or values}}

test registry-1.3 {argument parsing for registry command} {pcOnly} {
    list [catch {registry d} msg] $msg
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}
test registry-1.4 {argument parsing for registry command} {pcOnly} {
    list [catch {registry delete} msg] $msg
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}
test registry-1.5 {argument parsing for registry command} {pcOnly} {
    list [catch {registry delete foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry delete keyName ?valueName?"}}

test registry-1.6 {argument parsing for registry command} {pcOnly} {
    list [catch {registry g} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}
test registry-1.7 {argument parsing for registry command} {pcOnly} {
    list [catch {registry get} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}
test registry-1.8 {argument parsing for registry command} {pcOnly} {
    list [catch {registry get foo} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}
test registry-1.9 {argument parsing for registry command} {pcOnly} {
    list [catch {registry get foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry get keyName valueName"}}

test registry-1.10 {argument parsing for registry command} {pcOnly} {
    list [catch {registry k} msg] $msg
} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}
test registry-1.11 {argument parsing for registry command} {pcOnly} {
    list [catch {registry keys} msg] $msg
} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}
test registry-1.12 {argument parsing for registry command} {pcOnly} {
    list [catch {registry keys foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry keys keyName ?pattern?"}}

test registry-1.13 {argument parsing for registry command} {pcOnly} {
    list [catch {registry s} msg] $msg
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
test registry-1.14 {argument parsing for registry command} {pcOnly} {
    list [catch {registry set} msg] $msg
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
test registry-1.15 {argument parsing for registry command} {pcOnly} {
    list [catch {registry set foo bar} msg] $msg
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}
test registry-1.16 {argument parsing for registry command} {pcOnly} {
    list [catch {registry set foo bar baz blat gorp} msg] $msg
} {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}}

test registry-1.17 {argument parsing for registry command} {pcOnly} {
    list [catch {registry t} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}
test registry-1.18 {argument parsing for registry command} {pcOnly} {
    list [catch {registry type} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}
test registry-1.19 {argument parsing for registry command} {pcOnly} {
    list [catch {registry type foo} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}
test registry-1.20 {argument parsing for registry command} {pcOnly} {
    list [catch {registry type foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry type keyName valueName"}}

test registry-1.21 {argument parsing for registry command} {pcOnly} {
    list [catch {registry v} msg] $msg
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}
test registry-1.22 {argument parsing for registry command} {pcOnly} {
    list [catch {registry values} msg] $msg
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}
test registry-1.23 {argument parsing for registry command} {pcOnly} {
    list [catch {registry values foo bar baz} msg] $msg
} {1 {wrong # args: should be "registry values keyName ?pattern?"}}

test registry-2.1 {DeleteKey: bad key} {pcOnly} {
    list [catch {registry delete foo} msg] $msg
} {1 {bad root name "foo": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-2.2 {DeleteKey: bad key} {pcOnly} {
    list [catch {registry delete HKEY_CLASSES_ROOT} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-2.3 {DeleteKey: bad key} {pcOnly} {
    list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-2.4 {DeleteKey: subkey at root level} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry keys HKEY_CLASSES_ROOT TclFoobar
} {}
test registry-2.5 {DeleteKey: subkey below root level} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test
    registry delete HKEY_CLASSES_ROOT\\TclFoobar\\test
    set result [registry keys HKEY_CLASSES_ROOT TclFoobar\\test]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}
test registry-2.6 {DeleteKey: recursive delete} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry keys HKEY_CLASSES_ROOT TclFoobar]
    set result
} {}
test registry-2.7 {DeleteKey: trailing backslashes} {pcOnly english} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz
    list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar\\} msg] $msg
} {1 {unable to delete key: The configuration registry key is invalid.}}
test registry-2.8 {DeleteKey: failure} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
} {}


test registry-3.1 {DeleteValue} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test1 blort
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test2 blat
    registry delete HKEY_CLASSES_ROOT\\TclFoobar\\baz test1
    set result [registry values HKEY_CLASSES_ROOT\\TclFoobar\\baz]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} test2
test registry-3.2 {DeleteValue: bad key} {pcOnly english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar test} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-3.3 {DeleteValue: bad value} {pcOnly english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz test2 blort
    set result [list [catch {registry delete HKEY_CLASSES_ROOT\\TclFoobar test1} msg] $msg]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {1 {unable to delete value "test1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}}


test registry-4.1 {GetKeyNames: bad key} {pcOnly english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-4.2 {GetKeyNames} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz
    set result [registry keys HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {baz}
test registry-4.3 {GetKeyNames: remote key} {pcOnly nonPortable english} {
    registry set \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar\\baz
    set result [registry keys \\\\gaspode\\HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {baz}
test registry-4.4 {GetKeyNames: empty key} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry keys HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}
test registry-4.5 {GetKeyNames: patterns} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\foo
    set result [lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {baz blat}
test registry-4.6 {GetKeyNames: names with spaces} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz\ bar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\foo
    set result [lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{baz bar} blat}

test registry-5.1 {GetType} {pcOnly english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry type HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-5.2 {GetType} {pcOnly english} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry type HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg
} {1 {unable to get type of value "val1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}}
test registry-5.3 {GetType} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar none
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} none
test registry-5.4 {GetType} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} sz
test registry-5.5 {GetType} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar sz
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} sz
test registry-5.6 {GetType} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar expand_sz
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} expand_sz
test registry-5.7 {GetType} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 binary
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} binary
test registry-5.8 {GetType} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 dword
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} dword
test registry-5.9 {GetType} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 dword_big_endian
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} dword_big_endian
test registry-5.10 {GetType} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 link
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} link
test registry-5.11 {GetType} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar multi_sz
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} multi_sz
test registry-5.12 {GetType} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 resource_list
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} resource_list
test registry-5.13 {GetType: unknown types} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 24
    set result [registry type HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 24

test registry-6.1 {GetValue} {pcOnly english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry get HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-6.2 {GetValue} {pcOnly english} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry get HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg
} {1 {unable to get value "val1" from key "HKEY_CLASSES_ROOT\TclFoobar": The system cannot find the file specified.}}
test registry-6.3 {GetValue} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar none
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.4 {GetValue} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.5 {GetValue} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.6 {GetValue} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar expand_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.7 {GetValue} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 binary
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 1
test registry-6.8 {GetValue} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 0x20 dword
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 32
test registry-6.9 {GetValue} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 0x20 dword_big_endian
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 32
test registry-6.10 {GetValue} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 link
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 1
test registry-6.11 {GetValue} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 foobar multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} foobar
test registry-6.12 {GetValue} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {foo\ bar baz} multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{foo bar} baz}
test registry-6.13 {GetValue} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {} multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}
test registry-6.14 {GetValue: truncation of multivalues with null elements} \
	{pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 {a {} b} multi_sz
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} a
test registry-6.15 {GetValue} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 resource_list
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 1
test registry-6.16 {GetValue: unknown types} {pcOnly} {
    registry set HKEY_CLASSES_ROOT\\TclFoobar val1 1 24
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar val1]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} 1

test registry-7.1 {GetValueNames: bad key} {pcOnly english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry values HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-7.2 {GetValueNames} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar
    set result [registry values HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} baz
test registry-7.3 {GetValueNames} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar1
    registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2
    registry set HKEY_CLASSES_ROOT\\TclFoobar {} foobar3
    set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{} baz blat}
test registry-7.4 {GetValueNames: remote key} {pcOnly nonPortable english} {
    registry set \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar baz blat
    set result [registry values \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar
    set result
} baz
test registry-7.5 {GetValueNames: empty key} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry values HKEY_CLASSES_ROOT\\TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}
test registry-7.6 {GetValueNames: patterns} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz foobar1
    registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2
    registry set HKEY_CLASSES_ROOT\\TclFoobar foo foobar3
    set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {baz blat}
test registry-7.7 {GetValueNames: names with spaces} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar baz\ bar foobar1
    registry set HKEY_CLASSES_ROOT\\TclFoobar blat foobar2
    registry set HKEY_CLASSES_ROOT\\TclFoobar foo foobar3
    set result [lsort [registry values HKEY_CLASSES_ROOT\\TclFoobar b*]]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {{baz bar} blat}

test registry-8.1 {OpenSubKey} {pcOnly nonPortable english} {
    list [catch {registry keys {\\petrouchka\HKEY_LOCAL_MACHINE}} msg] $msg
} {1 {unable to open key: Access is denied.}}
test registry-8.2 {OpenSubKey} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry keys HKEY_CLASSES_ROOT TclFoobar]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} TclFoobar
test registry-8.3 {OpenSubKey} {pcOnly english} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}

test registry-9.1 {ParseKeyName: bad keys} {pcOnly} {
    list [catch {registry values \\} msg] $msg
} "1 {bad key \"\\\": must start with a valid root}"
test registry-9.2 {ParseKeyName: bad keys} {pcOnly} {
    list [catch {registry values \\foobar} msg] $msg
} {1 {bad key "\foobar": must start with a valid root}}
test registry-9.3 {ParseKeyName: bad keys} {pcOnly} {
    list [catch {registry values \\\\} msg] $msg
} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-9.4 {ParseKeyName: bad keys} {pcOnly} {
    list [catch {registry values \\\\\\} msg] $msg
} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-9.5 {ParseKeyName: bad keys} {pcOnly english} {
    list [catch {registry values \\\\\\HKEY_CLASSES_ROOT} msg] $msg
} {1 {unable to open key: The network address is invalid.}}
test registry-9.6 {ParseKeyName: bad keys} {pcOnly} {
    list [catch {registry values \\\\gaspode} msg] $msg
} {1 {ambiguous root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-9.7 {ParseKeyName: bad keys} {pcOnly} {
    list [catch {registry values foobar} msg] $msg
} {1 {bad root name "foobar": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}}
test registry-9.8 {ParseKeyName: null keys} {pcOnly} {
    list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg
} {1 {bad key: cannot delete root keys}}
test registry-9.9 {ParseKeyName: null keys} {pcOnly english} {
    list [catch {registry keys HKEY_CLASSES_ROOT\\TclFoobar\\baz} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}

test registry-10.1 {RecursiveDeleteKey} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result [registry keys HKEY_CLASSES_ROOT TclFoobar]
    set result
} {}
test registry-10.2 {RecursiveDeleteKey} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test1
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test3
    set result [registry delete HKEY_CLASSES_ROOT\\TclFoobar\\test2\\test4]
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    set result
} {}

test registry-11.1 {SetValue: recursive creation} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat foobar
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar\\baz blat]
} foobar
test registry-11.2 {SetValue: modification} {pcOnly} {
    registry delete HKEY_CLASSES_ROOT\\TclFoobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat foobar
    registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz blat frob
    set result [registry get HKEY_CLASSES_ROOT\\TclFoobar\\baz blat]
} frob
test registry-11.3 {SetValue: failure} {pcOnly nonPortable english} {
    list [catch {registry set {\\petrouchka\HKEY_CLASSES_ROOT\TclFoobar} bar foobar} msg] $msg
} {1 {unable to open key: Access is denied.}}


# cleanup
unset hostname
::tcltest::cleanupTests
return











Changes to tests/remote.tcl.

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
155
156
157
158
159
160
161










# Source this file in the remote server you are using to test Tcl against.
#
# 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.
#
# RCS: @(#) $Id: remote.tcl,v 1.1.2.1 1998/09/24 23:59:35 stanton Exp $

# Initialize message delimitor

# Initialize command array
catch {unset command}
set command(0) ""
set callerSocket ""
................................................................................

if {[catch {set serverSocket \
	[socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} {
    puts "Server on $serverAddress:$serverPort cannot start: $msg"
} else {
    vwait __server_wait_variable__
}
















|







 







>
>
>
>
>
>
>
>
>
>
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
# Source this file in the remote server you are using to test Tcl against.
#
# 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.
#
# RCS: @(#) $Id: remote.tcl,v 1.1.2.2 1999/03/23 20:06:50 hershey Exp $

# Initialize message delimitor

# Initialize command array
catch {unset command}
set command(0) ""
set callerSocket ""
................................................................................

if {[catch {set serverSocket \
	[socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} {
    puts "Server on $serverAddress:$serverPort cannot start: $msg"
} else {
    vwait __server_wait_variable__
}










Changes to tests/rename.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
165
166
167
168
169
170
171
172
173
174
175










# 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.
#
# RCS: @(#) $Id: rename.test,v 1.1.2.3 1999/03/11 18:50:05 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Must eliminate the "unknown" command while the test is running,
# especially if the test is being run in a program with its
# own special-purpose unknown command.

................................................................................
    catch {x} msg
    set msg
} {called "incr" with too many arguments}

# cleanup
catch {rename incr {}}
catch {rename incr.old incr}
::test::cleanupTests
return


















|

|







 







|



>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
# 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.
#
# RCS: @(#) $Id: rename.test,v 1.1.2.4 1999/03/23 20:06:51 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Must eliminate the "unknown" command while the test is running,
# especially if the test is being run in a program with its
# own special-purpose unknown command.

................................................................................
    catch {x} msg
    set msg
} {called "incr" with too many arguments}

# cleanup
catch {rename incr {}}
catch {rename incr.old incr}
::tcltest::cleanupTests
return












Changes to tests/resource.test.

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










#
# 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.
#
# RCS: @(#) $Id: resource.test,v 1.1.2.3 1999/03/11 18:50:05 hershey Exp $

# Only run this test on Macintosh systems
if {$tcl_platform(platform) != "macintosh"} {
    puts "skipping: Mac only tests..."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test resource-1.1 {resource tests} {
    list [catch {resource} msg] $msg
} {1 {wrong # args: should be "resource option ?arg ...?"}}
test resource-1.2 {resource tests} {
    list [catch {resource _bad_} msg] $msg
} {1 {bad option "_bad_": must be close, delete, files, list, open, read, types, or write}}

# resource open & close tests
test resource-2.1 {resource open & close tests} {
    list [catch {resource open} msg] $msg
} {1 {wrong # args: should be "resource open fileName ?permissions?"}}
test resource-2.2 {resource open & close tests} {
    list [catch {resource open resource.test r extraArg} msg] $msg
} {1 {wrong # args: should be "resource open fileName ?permissions?"}}
test resource-2.3 {resource open & close tests} {
    list [catch {resource open resource.test bad_perms} msg] $msg
} {1 {illegal access mode "bad_perms"}}
test resource-2.4 {resource open & close tests} {
    list [catch {resource open _bad_file_} msg] $msg
} {1 {file does not exist}}
test resource-2.5 {resource open & close tests} {
    testWriteTextResource -rsrc fileRsrcName -file rsrc.file  {error "don't source me"}
    set id [resource open rsrc.file]
    resource close $id
    file delete rsrc.file
} {}
test resource-2.6 {resource open & close tests} {
    catch {file delete rsrc.file}
    testWriteTextResource -rsrc fileRsrcName -file rsrc.file  {A test string}
    set id [resource open rsrc.file]
    set result [string compare [resource open rsrc.file] $id]
    lappend result [resource read TEXT fileRsrcName $id]
    resource close $id
    file delete rsrc.file
    set result
} {0 {A test string}}
test resource-2.7 {resource open & close tests} {
    catch {file delete rsrc.file}
    testWriteTextResource -rsrc fileRsrcName -file rsrc.file  {error "don't source me"}
    set id [resource open rsrc.file r]
    set result [catch {resource open rsrc.file w} mssg]
    resource close $id
    file delete rsrc.file
    lappend result $mssg
    set result
} {1 {Resource already open with different permissions.}}
test resource-2.8 {resource open & close tests} {
    list [catch {resource close} msg] $msg
} {1 {wrong # args: should be "resource close resourceRef"}}
test resource-2.9 {resource open & close tests} {
    list [catch {resource close foo bar} msg] $msg
} {1 {wrong # args: should be "resource close resourceRef"}}
test resource-2.10 {resource open & close tests} {
    list [catch {resource close _bad_resource_} msg] $msg
} {1 {invalid resource file reference "_bad_resource_"}}
test resource-2.11 {resource open & close tests} {
    set result [catch {resource close System} mssg]
    lappend result $mssg
} {1 {can't close "System" resource file}}
test resource-2.12 {resource open & close tests} {
    set result [catch {resource close application} mssg]
    lappend result $mssg
} {1 {can't close "application" resource file}}

# Tests for listing resources
test resource-3.1 {resource list tests} {
    list [catch {resource list} msg] $msg
} {1 {wrong # args: should be "resource list resourceType ?resourceRef?"}}
test resource-3.2 {resource list tests} {
    list [catch {resource list _bad_type_} msg] $msg
} {1 {expected Macintosh OS type but got "_bad_type_"}}
test resource-3.3 {resource list tests} {
    list [catch {resource list TEXT _bad_ref_} msg] $msg
} {1 {invalid resource file reference "_bad_ref_"}}
test resource-3.4 {resource list tests} {
    list [catch {resource list TEXT _bad_ref_ extraArg} msg] $msg
} {1 {wrong # args: should be "resource list resourceType ?resourceRef?"}}
test resource-3.5 {resource list tests} {
    catch {file delete rsrc.file}
    testWriteTextResource -rsrc fileRsrcName -file rsrc.file  {error "don't source me"}
    set id [resource open rsrc.file]
    catch "resource list TEXT $id" result
    resource close $id
    set result
} {fileRsrcName}
test resource-3.6 {resource list tests} {
    # There should not be any resource of this type
    resource list XXXX
} {}
test resource-3.7 {resource list tests} {
    set resourceList [resource list STR#]
    if {[lsearch $resourceList {Tcl Environment Variables}] == -1} {
        set result {couldn't find resource that should exist}
    } else {
        set result ok
    }
} {ok}

# Tests for reading resources
test resource-4.1 {resource read tests} {
    list [catch {resource read} msg] $msg
} {1 {wrong # args: should be "resource read resourceType resourceId ?resourceRef?"}}
test resource-4.2 {resource read tests} {
    list [catch {resource read TEXT} msg] $msg
} {1 {wrong # args: should be "resource read resourceType resourceId ?resourceRef?"}}
test resource-4.3 {resource read tests} {
    list [catch {resource read STR# {_non_existant_resource_}} msg] $msg
} {1 {could not load resource}}
test resource-4.4 {resource read tests} {
    # The following resource should exist and load OK without error
    catch {resource read STR# {Tcl Environment Variables}}
} {0}

# Tests for getting resource types
test resource-5.1 {resource types tests} {
    list [catch {resource types _bad_ref_} msg] $msg
} {1 {invalid resource file reference "_bad_ref_"}}
test resource-5.2 {resource types tests} {
    list [catch {resource types _bad_ref_ extraArg} msg] $msg
} {1 {wrong # args: should be "resource types ?resourceRef?"}}
test resource-5.3 {resource types tests} {
    # This should never cause an error
    catch {resource types}
} {0}
test resource-5.4 {resource types tests} {
    testWriteTextResource -rsrc fileRsrcName -file rsrc.file  {error "don't source me"}
    set id [resource open rsrc.file]
    set result [resource types $id]
    resource close $id
    set result
} {TEXT}

# resource write tests
test resource-6.1 {resource write tests} {
    list [catch {resource write} msg] $msg
} {1 {wrong # args: should be "resource write ?-id resourceId? ?-name resourceName? ?-file resourceRef? ?-force? resourceType data"}}
test resource-6.2 {resource write tests} {
    list [catch {resource write _bad_type_ data} msg] $msg
} {1 {expected Macintosh OS type but got "_bad_type_"}}
test resource-6.3 {resource write tests} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    resource close $id
    set id [resource open rsrc2.file r]
    set result [catch {resource write -file $id -name Hello TEXT foo} errMsg]
    lappend result [string compare $errMsg "cannot write to resource file \"$id\", it was opened read only"]
    lappend result [lsearch [resource list TEXT $id] Hello]
    resource close $id
    file delete rsrc2.file
    set result   
} {1 0 -1}
test resource-6.4 {resource write tests} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    resource write -file $id -name Hello TEXT {set x "our test data"}
    source -rsrc Hello rsrc2.file
    resource close $id
    file delete rsrc2.file
    set x
} {our test data}
test resource-6.5 {resource write tests} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    resource write -file $id -id 256 TEXT {HAHAHAHAHAHAHA}
    set result [catch {resource write -file $id -id 256 TEXT {HOHOHOHOHOHO}} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {the resource 256 already exists, use "-force" to overwrite it.}}
test resource-6.6 {resource write tests} {
    catch {file delete rsrc2.file}
    testWriteTextResource -rsrc fileRsrcName -rsrcid 256  -file rsrc2.file  -protected {error "don't tread on me"}
    set id [resource open rsrc2.file w]
    set result [catch {resource write -id 256 -force -file $id TEXT {NAHNAHNANAHNAH}} mssg] 
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {could not write resource id 256 of type TEXT, it was protected.}}
test resource-6.7 {resource write tests} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    resource write -file $id -id 256 -name FOO TEXT {set x [list "our first test data"]}
    resource write -file $id -id 256 -name BAR -force TEXT {set x [list "our second test data"]}
    source -rsrcid 256 rsrc2.file
    lappend x [resource list TEXT $id]
    resource close $id
    file delete rsrc2.file
    set x
} {{our second test data} BAR}

#Tests for listing open resource files
test resource-7.1 {resource file tests} {
    catch {resource files foo bar} mssg
    set mssg
} {wrong # args: should be "resource files ?resourceId?"}
test resource-7.2 {resource file tests} {
    catch {file delete rsrc2.file}
    set rsrcFiles [resource files]
    set id [resource open rsrc2.file w]
    set result [string compare $rsrcFiles [lrange [resource files] 1 end]]
    lappend result [string compare $id [lrange [resource files] 0 0]]
    resource close $id
    file delete rsrc2.file
    set result
} {0 0}
test resource-7.3 {resource file tests} {
    set result 0
    foreach file [resource files] {
        if {[catch {resource types $file}] != 0} {
            set result 1
        }
    }
    set result
} {0}
test resource-7.4 {resource file tests} {
    catch {resource files __NO_SUCH_RESOURCE__} mssg
    set mssg
} {invalid resource file reference "__NO_SUCH_RESOURCE__"}
test resource-7.5 {resource file tests} {
    set sys [resource files System]
    string compare $sys [file join $env(SYS_FOLDER) System]
} {0}
test resource-7.6 {resource file tests} {
    set app [resource files application]
    string compare $app [info nameofexecutable]
} {0}

#Tests for the resource delete command
test resource-8.1 {resource delete tests} {
    list [catch {resource delete} msg] $msg
} {1 {wrong # args: should be "resource delete ?-id resourceId? ?-name resourceName? ?-file resourceRef? resourceType"}}
test resource-8.2 {resource delete tests} {
    list [catch {resource delete TEXT} msg] $msg
} {1 {you must specify either "-id" or "-name" or both to "resource delete"}}
test resource-8.3 {resource delete tests} {
    set result [catch {resource delete -file ffffff -id 128 TEXT} mssg]
    lappend result $mssg    
} {1 {invalid resource file reference "ffffff"}}    
test resource-8.4 {resource delete tests} {
    catch {file delete rsrc2.file}
    testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
    set id [resource open rsrc2.file r]
    set result [catch {resource delete -id 128 -file $id TEXT} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result [string compare $mssg "cannot delete from resource file \"$id\", it was opened read only"]   
} {1 0}
test resource-8.5 {resource delete tests} {
    catch {file delete rsrc2.file}
    testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
    set id [resource open rsrc2.file w]
    set result [catch {resource delete -id 128 -file $id _bad_type_} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {expected Macintosh OS type but got "_bad_type_"}}
test resource-8.5 {resource delete tests} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    set result [catch {resource delete -id 128 -file $id TEXT} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {resource not found}}
test resource-8.6 {resource delete tests} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    set result [catch {resource delete -name foo -file $id TEXT} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {resource not found}}
test resource-8.7 {resource delete tests} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    resource write -file $id -name foo -id 128 TEXT {some stuff}
    resource write -file $id -name bar -id 129 TEXT {some stuff}
    set result [catch {resource delete -name foo -id 129 -file $id TEXT} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {"-id" and "-name" values do not point to the same resource}}
test resource-8.8 {resource delete tests} {
    catch {file delete rsrc2.file}
    testWriteTextResource -rsrc fileRsrcName -rsrcid 256  -file rsrc2.file  -protected {error "don't tread on me"}
    set id [resource open rsrc2.file w]
    set result [catch {resource delete -id 256 -file $id TEXT } mssg] 
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {resource cannot be deleted: it is protected.}}
test resource-8.9 {resource delete tests} {
    catch {file delete rsrc2.file}
    testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
    set id [resource open rsrc2.file w]
    set result [resource list TEXT $id]
    resource delete -id 128 -file $id TEXT
    lappend result [resource list TEXT $id]
    resource close $id
    file delete rsrc2.file
    set result
} {fileRsrcName {}}
    
# Tests for the Mac version of the source command
catch {file delete rsrc.file}

testWriteTextResource -rsrc fileRsrcName -rsrcid 128 \
    -file rsrc.file  {set rsrc_foo 1}
test resource-9.1 {source command} {
    catch {unset rsrc_foo}
    source -rsrc fileRsrcName rsrc.file
    list [catch {set rsrc_foo} msg] $msg
} {0 1}
test resource-9.2 {source command} {
    catch {unset rsrc_foo}
    list [catch {source -rsrc no_resource rsrc.file} msg] $msg
} {1 {The resource "no_resource" could not be loaded from rsrc.file.}}
test resource-9.3 {source command} {
    catch {unset rsrc_foo}
    source -rsrcid 128 rsrc.file
    list [catch {set rsrc_foo} msg] $msg
} {0 1}
test resource-9.4 {source command} {
    catch {unset rsrc_foo}
    list [catch {source -rsrcid bad_int rsrc.file} msg] $msg
} {1 {expected integer but got "bad_int"}}
test resource-9.5 {source command} {
    catch {unset rsrc_foo}
    list [catch {source -rsrcid 100 rsrc.file} msg] $msg
} {1 {The resource "ID=100" could not be loaded from rsrc.file.}}

# cleanup
catch {file delete rsrc.file}
::test::cleanupTests
return

















|

<
<
<
<
<
<
|



|


|




|


|


|


|


|





|









|









|


|


|


|



|





|


|


|


|


|







|



|









|


|


|


|





|


|


|



|








|


|


|











|








|








|








|












|



|









|








|



|



|





|


|


|



|








|








|







|







|









|








|













>
|
|
<




|



|




|



|






|


>
>
>
>
>
>
>
>
>
>
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
#
# 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.
#
# RCS: @(#) $Id: resource.test,v 1.1.2.4 1999/03/23 20:06:51 hershey Exp $







if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test resource-1.1 {resource tests} {macOnly} {
    list [catch {resource} msg] $msg
} {1 {wrong # args: should be "resource option ?arg ...?"}}
test resource-1.2 {resource tests} {macOnly} {
    list [catch {resource _bad_} msg] $msg
} {1 {bad option "_bad_": must be close, delete, files, list, open, read, types, or write}}

# resource open & close tests
test resource-2.1 {resource open & close tests} {macOnly} {
    list [catch {resource open} msg] $msg
} {1 {wrong # args: should be "resource open fileName ?permissions?"}}
test resource-2.2 {resource open & close tests} {macOnly} {
    list [catch {resource open resource.test r extraArg} msg] $msg
} {1 {wrong # args: should be "resource open fileName ?permissions?"}}
test resource-2.3 {resource open & close tests} {macOnly} {
    list [catch {resource open resource.test bad_perms} msg] $msg
} {1 {illegal access mode "bad_perms"}}
test resource-2.4 {resource open & close tests} {macOnly} {
    list [catch {resource open _bad_file_} msg] $msg
} {1 {file does not exist}}
test resource-2.5 {resource open & close tests} {macOnly} {
    testWriteTextResource -rsrc fileRsrcName -file rsrc.file  {error "don't source me"}
    set id [resource open rsrc.file]
    resource close $id
    file delete rsrc.file
} {}
test resource-2.6 {resource open & close tests} {macOnly} {
    catch {file delete rsrc.file}
    testWriteTextResource -rsrc fileRsrcName -file rsrc.file  {A test string}
    set id [resource open rsrc.file]
    set result [string compare [resource open rsrc.file] $id]
    lappend result [resource read TEXT fileRsrcName $id]
    resource close $id
    file delete rsrc.file
    set result
} {0 {A test string}}
test resource-2.7 {resource open & close tests} {macOnly} {
    catch {file delete rsrc.file}
    testWriteTextResource -rsrc fileRsrcName -file rsrc.file  {error "don't source me"}
    set id [resource open rsrc.file r]
    set result [catch {resource open rsrc.file w} mssg]
    resource close $id
    file delete rsrc.file
    lappend result $mssg
    set result
} {1 {Resource already open with different permissions.}}
test resource-2.8 {resource open & close tests} {macOnly} {
    list [catch {resource close} msg] $msg
} {1 {wrong # args: should be "resource close resourceRef"}}
test resource-2.9 {resource open & close tests} {macOnly} {
    list [catch {resource close foo bar} msg] $msg
} {1 {wrong # args: should be "resource close resourceRef"}}
test resource-2.10 {resource open & close tests} {macOnly} {
    list [catch {resource close _bad_resource_} msg] $msg
} {1 {invalid resource file reference "_bad_resource_"}}
test resource-2.11 {resource open & close tests} {macOnly} {
    set result [catch {resource close System} mssg]
    lappend result $mssg
} {1 {can't close "System" resource file}}
test resource-2.12 {resource open & close tests} {macOnly} {
    set result [catch {resource close application} mssg]
    lappend result $mssg
} {1 {can't close "application" resource file}}

# Tests for listing resources
test resource-3.1 {resource list tests} {macOnly} {
    list [catch {resource list} msg] $msg
} {1 {wrong # args: should be "resource list resourceType ?resourceRef?"}}
test resource-3.2 {resource list tests} {macOnly} {
    list [catch {resource list _bad_type_} msg] $msg
} {1 {expected Macintosh OS type but got "_bad_type_"}}
test resource-3.3 {resource list tests} {macOnly} {
    list [catch {resource list TEXT _bad_ref_} msg] $msg
} {1 {invalid resource file reference "_bad_ref_"}}
test resource-3.4 {resource list tests} {macOnly} {
    list [catch {resource list TEXT _bad_ref_ extraArg} msg] $msg
} {1 {wrong # args: should be "resource list resourceType ?resourceRef?"}}
test resource-3.5 {resource list tests} {macOnly} {
    catch {file delete rsrc.file}
    testWriteTextResource -rsrc fileRsrcName -file rsrc.file  {error "don't source me"}
    set id [resource open rsrc.file]
    catch "resource list TEXT $id" result
    resource close $id
    set result
} {fileRsrcName}
test resource-3.6 {resource list tests} {macOnly} {
    # There should not be any resource of this type
    resource list XXXX
} {}
test resource-3.7 {resource list tests} {macOnly} {
    set resourceList [resource list STR#]
    if {[lsearch $resourceList {Tcl Environment Variables}] == -1} {
        set result {couldn't find resource that should exist}
    } else {
        set result ok
    }
} {ok}

# Tests for reading resources
test resource-4.1 {resource read tests} {macOnly} {
    list [catch {resource read} msg] $msg
} {1 {wrong # args: should be "resource read resourceType resourceId ?resourceRef?"}}
test resource-4.2 {resource read tests} {macOnly} {
    list [catch {resource read TEXT} msg] $msg
} {1 {wrong # args: should be "resource read resourceType resourceId ?resourceRef?"}}
test resource-4.3 {resource read tests} {macOnly} {
    list [catch {resource read STR# {_non_existant_resource_}} msg] $msg
} {1 {could not load resource}}
test resource-4.4 {resource read tests} {macOnly} {
    # The following resource should exist and load OK without error
    catch {resource read STR# {Tcl Environment Variables}}
} {0}

# Tests for getting resource types
test resource-5.1 {resource types tests} {macOnly} {
    list [catch {resource types _bad_ref_} msg] $msg
} {1 {invalid resource file reference "_bad_ref_"}}
test resource-5.2 {resource types tests} {macOnly} {
    list [catch {resource types _bad_ref_ extraArg} msg] $msg
} {1 {wrong # args: should be "resource types ?resourceRef?"}}
test resource-5.3 {resource types tests} {macOnly} {
    # This should never cause an error
    catch {resource types}
} {0}
test resource-5.4 {resource types tests} {macOnly} {
    testWriteTextResource -rsrc fileRsrcName -file rsrc.file  {error "don't source me"}
    set id [resource open rsrc.file]
    set result [resource types $id]
    resource close $id
    set result
} {TEXT}

# resource write tests
test resource-6.1 {resource write tests} {macOnly} {
    list [catch {resource write} msg] $msg
} {1 {wrong # args: should be "resource write ?-id resourceId? ?-name resourceName? ?-file resourceRef? ?-force? resourceType data"}}
test resource-6.2 {resource write tests} {macOnly} {
    list [catch {resource write _bad_type_ data} msg] $msg
} {1 {expected Macintosh OS type but got "_bad_type_"}}
test resource-6.3 {resource write tests} {macOnly} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    resource close $id
    set id [resource open rsrc2.file r]
    set result [catch {resource write -file $id -name Hello TEXT foo} errMsg]
    lappend result [string compare $errMsg "cannot write to resource file \"$id\", it was opened read only"]
    lappend result [lsearch [resource list TEXT $id] Hello]
    resource close $id
    file delete rsrc2.file
    set result   
} {1 0 -1}
test resource-6.4 {resource write tests} {macOnly} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    resource write -file $id -name Hello TEXT {set x "our test data"}
    source -rsrc Hello rsrc2.file
    resource close $id
    file delete rsrc2.file
    set x
} {our test data}
test resource-6.5 {resource write tests} {macOnly} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    resource write -file $id -id 256 TEXT {HAHAHAHAHAHAHA}
    set result [catch {resource write -file $id -id 256 TEXT {HOHOHOHOHOHO}} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {the resource 256 already exists, use "-force" to overwrite it.}}
test resource-6.6 {resource write tests} {macOnly} {
    catch {file delete rsrc2.file}
    testWriteTextResource -rsrc fileRsrcName -rsrcid 256  -file rsrc2.file  -protected {error "don't tread on me"}
    set id [resource open rsrc2.file w]
    set result [catch {resource write -id 256 -force -file $id TEXT {NAHNAHNANAHNAH}} mssg] 
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {could not write resource id 256 of type TEXT, it was protected.}}
test resource-6.7 {resource write tests} {macOnly} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    resource write -file $id -id 256 -name FOO TEXT {set x [list "our first test data"]}
    resource write -file $id -id 256 -name BAR -force TEXT {set x [list "our second test data"]}
    source -rsrcid 256 rsrc2.file
    lappend x [resource list TEXT $id]
    resource close $id
    file delete rsrc2.file
    set x
} {{our second test data} BAR}

#Tests for listing open resource files
test resource-7.1 {resource file tests} {macOnly} {
    catch {resource files foo bar} mssg
    set mssg
} {wrong # args: should be "resource files ?resourceId?"}
test resource-7.2 {resource file tests} {macOnly} {
    catch {file delete rsrc2.file}
    set rsrcFiles [resource files]
    set id [resource open rsrc2.file w]
    set result [string compare $rsrcFiles [lrange [resource files] 1 end]]
    lappend result [string compare $id [lrange [resource files] 0 0]]
    resource close $id
    file delete rsrc2.file
    set result
} {0 0}
test resource-7.3 {resource file tests} {macOnly} {
    set result 0
    foreach file [resource files] {
        if {[catch {resource types $file}] != 0} {
            set result 1
        }
    }
    set result
} {0}
test resource-7.4 {resource file tests} {macOnly} {
    catch {resource files __NO_SUCH_RESOURCE__} mssg
    set mssg
} {invalid resource file reference "__NO_SUCH_RESOURCE__"}
test resource-7.5 {resource file tests} {macOnly} {
    set sys [resource files System]
    string compare $sys [file join $env(SYS_FOLDER) System]
} {0}
test resource-7.6 {resource file tests} {macOnly} {
    set app [resource files application]
    string compare $app [info nameofexecutable]
} {0}

#Tests for the resource delete command
test resource-8.1 {resource delete tests} {macOnly} {
    list [catch {resource delete} msg] $msg
} {1 {wrong # args: should be "resource delete ?-id resourceId? ?-name resourceName? ?-file resourceRef? resourceType"}}
test resource-8.2 {resource delete tests} {macOnly} {
    list [catch {resource delete TEXT} msg] $msg
} {1 {you must specify either "-id" or "-name" or both to "resource delete"}}
test resource-8.3 {resource delete tests} {macOnly} {
    set result [catch {resource delete -file ffffff -id 128 TEXT} mssg]
    lappend result $mssg    
} {1 {invalid resource file reference "ffffff"}}    
test resource-8.4 {resource delete tests} {macOnly} {
    catch {file delete rsrc2.file}
    testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
    set id [resource open rsrc2.file r]
    set result [catch {resource delete -id 128 -file $id TEXT} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result [string compare $mssg "cannot delete from resource file \"$id\", it was opened read only"]   
} {1 0}
test resource-8.5 {resource delete tests} {macOnly} {
    catch {file delete rsrc2.file}
    testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
    set id [resource open rsrc2.file w]
    set result [catch {resource delete -id 128 -file $id _bad_type_} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {expected Macintosh OS type but got "_bad_type_"}}
test resource-8.5 {resource delete tests} {macOnly} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    set result [catch {resource delete -id 128 -file $id TEXT} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {resource not found}}
test resource-8.6 {resource delete tests} {macOnly} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    set result [catch {resource delete -name foo -file $id TEXT} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {resource not found}}
test resource-8.7 {resource delete tests} {macOnly} {
    catch {file delete rsrc2.file}
    set id [resource open rsrc2.file w]
    resource write -file $id -name foo -id 128 TEXT {some stuff}
    resource write -file $id -name bar -id 129 TEXT {some stuff}
    set result [catch {resource delete -name foo -id 129 -file $id TEXT} mssg]
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {"-id" and "-name" values do not point to the same resource}}
test resource-8.8 {resource delete tests} {macOnly} {
    catch {file delete rsrc2.file}
    testWriteTextResource -rsrc fileRsrcName -rsrcid 256  -file rsrc2.file  -protected {error "don't tread on me"}
    set id [resource open rsrc2.file w]
    set result [catch {resource delete -id 256 -file $id TEXT } mssg] 
    resource close $id
    file delete rsrc2.file
    lappend result $mssg
} {1 {resource cannot be deleted: it is protected.}}
test resource-8.9 {resource delete tests} {macOnly} {
    catch {file delete rsrc2.file}
    testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
    set id [resource open rsrc2.file w]
    set result [resource list TEXT $id]
    resource delete -id 128 -file $id TEXT
    lappend result [resource list TEXT $id]
    resource close $id
    file delete rsrc2.file
    set result
} {fileRsrcName {}}
    
# Tests for the Mac version of the source command
catch {file delete rsrc.file}
test resource-9.1 {source command} {macOnly} {
    testWriteTextResource -rsrc fileRsrcName -rsrcid 128 \
	    -file rsrc.file  {set rsrc_foo 1}

    catch {unset rsrc_foo}
    source -rsrc fileRsrcName rsrc.file
    list [catch {set rsrc_foo} msg] $msg
} {0 1}
test resource-9.2 {source command} {macOnly} {
    catch {unset rsrc_foo}
    list [catch {source -rsrc no_resource rsrc.file} msg] $msg
} {1 {The resource "no_resource" could not be loaded from rsrc.file.}}
test resource-9.3 {source command} {macOnly} {
    catch {unset rsrc_foo}
    source -rsrcid 128 rsrc.file
    list [catch {set rsrc_foo} msg] $msg
} {0 1}
test resource-9.4 {source command} {macOnly} {
    catch {unset rsrc_foo}
    list [catch {source -rsrcid bad_int rsrc.file} msg] $msg
} {1 {expected integer but got "bad_int"}}
test resource-9.5 {source command} {macOnly} {
    catch {unset rsrc_foo}
    list [catch {source -rsrcid 100 rsrc.file} msg] $msg
} {1 {The resource "ID=100" could not be loaded from rsrc.file.}}

# cleanup
catch {file delete rsrc.file}
::tcltest::cleanupTests
return











Changes to tests/result.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
77
78
79
80
81
82
83
84
85
86










# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) result.test 1.4 97/12/08 15:07:49

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test result-1.1 {Tcl_SaveInterpResult} {
    testsaveresult small {set x 42} 0
} {small result}
test result-1.2 {Tcl_SaveInterpResult} {
................................................................................
} {{1 2 3 4}}
test result-4.5 {Tcl_SetObjErrorCode - five args} {
    catch {testsetobjerrorcode 1 2 3 4 5}
    list [set errorCode]
} {{1 2 3 4 5}}

# cleanup
::test::cleanupTests
return

















|







 







|


>
>
>
>
>
>
>
>
>
>
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) result.test 1.4 97/12/08 15:07:49

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test result-1.1 {Tcl_SaveInterpResult} {
    testsaveresult small {set x 42} 0
} {small result}
test result-1.2 {Tcl_SaveInterpResult} {
................................................................................
} {{1 2 3 4}}
test result-4.5 {Tcl_SetObjErrorCode - five args} {
    catch {testsetobjerrorcode 1 2 3 4 5}
    list [set errorCode]
} {{1 2 3 4 5}}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/safe.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
435
436
437
438
439
440
441
442
443
444










#
# 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.
#
# RCS: @(#) $Id: safe.test,v 1.1.2.4 1999/03/11 18:50:06 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

foreach i [interp slaves] {
  interp delete $i
}

................................................................................
            [safe::interpDelete $i];
} {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}}


}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
#
# 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.
#
# RCS: @(#) $Id: safe.test,v 1.1.2.5 1999/03/23 20:06:52 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

foreach i [interp slaves] {
  interp delete $i
}

................................................................................
            [safe::interpDelete $i];
} {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}}


}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/scan.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
...
564
565
566
567
568
569
570
571
572










573
574
575
# Copyright (c) 1991-1994 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: scan.test,v 1.1.2.5 1999/03/11 18:50:06 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test scan-1.1 {BuildCharSet, CharInSet} {
    list [scan foo {%[^o]} x] $x
} {1 f}
test scan-1.2 {BuildCharSet, CharInSet} {
................................................................................
    list [scan "1 2 " "%hd %d %d %d" a b c d] $a $b $c $d
} {2 1 2 {} {}}
#
# The behavior for scaning intergers larger than MAX_INT is
# not defined by the ANSI spec.  Some implementations wrap the
# input (-16) some return MAX_INT.
#
test scan-5.11 {integer scanning} {nonportable} {
    set a {}; set b {};
    list [scan "4294967280 4294967280" "%u %d" a b] $a \
	    [expr {$b == -16 || $b == 0x7fffffff}]
} {2 4294967280 1}

test scan-6.1 {floating-point scanning} {
    set a {}; set b {}; set c {}; set d {}
................................................................................
} 13.6
test scan-11.5 {alignment in results array (TCL_ALIGN)} {
    scan "1234567890123456789 13.6" "%s %f" a b
    set b
} 13.6

# cleanup
::test::cleanupTests
return



















|

|







 







|







 







|

>
>
>
>
>
>
>
>
>
>



7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
...
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
# Copyright (c) 1991-1994 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: scan.test,v 1.1.2.6 1999/03/23 20:06:52 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test scan-1.1 {BuildCharSet, CharInSet} {
    list [scan foo {%[^o]} x] $x
} {1 f}
test scan-1.2 {BuildCharSet, CharInSet} {
................................................................................
    list [scan "1 2 " "%hd %d %d %d" a b c d] $a $b $c $d
} {2 1 2 {} {}}
#
# The behavior for scaning intergers larger than MAX_INT is
# not defined by the ANSI spec.  Some implementations wrap the
# input (-16) some return MAX_INT.
#
test scan-5.11 {integer scanning} {nonPortable} {
    set a {}; set b {};
    list [scan "4294967280 4294967280" "%u %d" a b] $a \
	    [expr {$b == -16 || $b == 0x7fffffff}]
} {2 4294967280 1}

test scan-6.1 {floating-point scanning} {
    set a {}; set b {}; set c {}; set d {}
................................................................................
} 13.6
test scan-11.5 {alignment in results array (TCL_ALIGN)} {
    scan "1234567890123456789 13.6" "%s %f" a b
    set b
} 13.6

# cleanup
::tcltest::cleanupTests
return













Changes to tests/security.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
34
35
36
37
38
39
40
41
42










# 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.
#
# RCS: @(#) $Id: security.test,v 1.1.2.2 1999/03/11 18:50:07 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# If this proc becomes invoked, then there is a bug

proc BUG {args} {
  set ::BUG 1
................................................................................

test sec-1.1 {tcl_endOfPreviousWord} {
    catch {tcl_startOfPreviousWord x {[BUG]}}
    CB
} 0

# cleanup
::test::cleanupTests
return
















|

|







 







|

>
>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
# 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.
#
# RCS: @(#) $Id: security.test,v 1.1.2.3 1999/03/23 20:06:53 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# If this proc becomes invoked, then there is a bug

proc BUG {args} {
  set ::BUG 1
................................................................................

test sec-1.1 {tcl_endOfPreviousWord} {
    catch {tcl_startOfPreviousWord x {[BUG]}}
    CB
} 0

# cleanup
::tcltest::cleanupTests
return










Changes to tests/set-old.test.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
791
792
793
794
795
796
797
798
799
800










# Copyright (c) 1991-1993 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: set-old.test,v 1.1.2.3 1999/03/11 18:50:07 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc ignore args {}

# Simple variable operations.

................................................................................
# scalars by other tests.
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset aVaRnAmE}

# cleanup
::test::cleanupTests
return 

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
# Copyright (c) 1991-1993 The Regents of the University of California.
# 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.
#
# RCS: @(#) $Id: set-old.test,v 1.1.2.4 1999/03/23 20:06:53 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc ignore args {}

# Simple variable operations.

................................................................................
# scalars by other tests.
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset aVaRnAmE}

# cleanup
::tcltest::cleanupTests
return 











Changes to tests/set.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
479
480
481
482
483
484
485
486
487
488










#
# 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.
#
# RCS: @(#) $Id: set.test,v 1.1.2.3 1999/03/11 18:50:08 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset x}
catch {unset i}

test set-1.1 {TclCompileSetCmd: missing variable name} {
................................................................................

# cleanup
catch {unset a}
catch {unset b}
catch {unset i}
catch {unset x}
catch {unset z}
::test::cleanupTests
return 

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
#
# 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.
#
# RCS: @(#) $Id: set.test,v 1.1.2.4 1999/03/23 20:06:54 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset x}
catch {unset i}

test set-1.1 {TclCompileSetCmd: missing variable name} {
................................................................................

# cleanup
catch {unset a}
catch {unset b}
catch {unset i}
catch {unset x}
catch {unset z}
::tcltest::cleanupTests
return 











Changes to tests/socket.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
...
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
...
147
148
149
150
151
152
153
154
155

156
157
158
159
160
161
162
163
164
165
...
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
...
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
...
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
...
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
...
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
...
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
...
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
...
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
...
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
...
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
...
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
...
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
...
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
...
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
...
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
...
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
...
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
...
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
...
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
...
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
...
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
...
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
....
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
....
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
....
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
....
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
....
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
....
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
....
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
....
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
....
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
....
1367
1368
1369
1370
1371
1372
1373
1374

1375
1376
1377
1378
1379
1380
1381
....
1418
1419
1420
1421
1422
1423
1424
1425

1426
1427
1428
1429
1430
1431
1432
....
1503
1504
1505
1506
1507
1508
1509
1510

1511
1512
1513
1514
1515
1516
1517
....
1585
1586
1587
1588
1589
1590
1591
1592
1593

1594









#
# 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.
#
# RCS: @(#) $Id: socket.test,v 1.1.2.6 1999/03/12 19:51:32 hershey Exp $

# Running socket tests with a remote server:
# ------------------------------------------
# 
# Some tests in socket.test depend on the existence of a remote server to
# which they connect. The remote server must be an instance of tcltest and it
# must run the script found in the file "remote.tcl" in this directory. You
................................................................................
# either in Tcl or in the environment; if they are, it attempts to connect to
# 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 {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {$::test::testConfig(socket) == 0} {
    puts "skipping: tests require sockets"
    return
}

#
# If remoteServerIP or remoteServerPort are not set, check in the
# environment variables for externally set values.
#

if {![info exists remoteServerIP]} {
    if {[info exists env(remoteServerIP)]} {
................................................................................
if {$doTestsWithRemoteServer} {
    catch {close $commandSocket}
    if {[catch {set commandSocket [socket $remoteServerIP \
						$remoteServerPort]}] != 0} {
	if {[info commands exec] == ""} {
	    set noRemoteTestReason "can't exec"
	    set doTestsWithRemoteServer 0
	} elseif {$::test::testConfig(win32s)} {
	    set noRemoteTestReason "\ncan't run multiple instances of tcltest under win32s."
	    set doTestsWithRemoteServer 0
	} else {
	    set remoteServerIP 127.0.0.1
	    set remoteFile [file join [pwd] remote.tcl]
	    if {[catch {set remoteProcChan \
				[open "|[list $tcltest $remoteFile \
					-serverIsSilent \
					-port $remoteServerPort \
................................................................................
	}
    } else {
	fconfigure $commandSocket -translation crlf -buffering line
    }
}

# Some tests are run only if we are doing testing against a remote server.
set ::test::testConfig(doTestsWithRemoteServer) $doTestsWithRemoteServer
if {$doTestsWithRemoteServer == 0} {

    puts "Skipping tests with remote server. See tests/socket.test for"
    puts "information on how to run remote server."
    if {$::test::verbose != ""} {
	puts "Reason for not doing remote tests: $noRemoteTestReason"
    }
}

#
# If we do the tests, define a command to send a command to the
# remote server.
................................................................................
	    } else {
		append resp $line "\n"
	    }
	}
    }
}

test socket-1.1 {arg parsing for socket command} {
    list [catch {socket -server} msg] $msg
} {1 {no argument given for -server option}}
test socket-1.2 {arg parsing for socket command} {
    list [catch {socket -server foo} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.3 {arg parsing for socket command} {
    list [catch {socket -myaddr} msg] $msg
} {1 {no argument given for -myaddr option}}
test socket-1.4 {arg parsing for socket command} {
    list [catch {socket -myaddr 127.0.0.1} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.5 {arg parsing for socket command} {
    list [catch {socket -myport} msg] $msg
} {1 {no argument given for -myport option}}
test socket-1.6 {arg parsing for socket command} {
    list [catch {socket -myport xxxx} msg] $msg
} {1 {expected integer but got "xxxx"}}
test socket-1.7 {arg parsing for socket command} {
    list [catch {socket -myport 2522} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.8 {arg parsing for socket command} {
    list [catch {socket -froboz} msg] $msg
} {1 {bad option "-froboz": must be -async, -myaddr, -myport, or -server}}
test socket-1.9 {arg parsing for socket command} {
    list [catch {socket -server foo -myport 2521 3333} msg] $msg
} {1 {Option -myport is not valid for servers}}
test socket-1.10 {arg parsing for socket command} {
    list [catch {socket host 2528 -junk} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.11 {arg parsing for socket command} {
    list [catch {socket -server callback 2520 --} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.12 {arg parsing for socket command} {
    list [catch {socket foo badport} msg] $msg
} {1 {expected integer but got "badport"}}

test socket-2.1 {tcp connection} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x timed_out"]
	set f [socket -server accept 2828]
	proc accept {file addr port} {
	    global x
................................................................................
} {ready done {}}

if [info exists port] {
    incr port
} else { 
    set port [expr 2048 + [pid]%1024]
}
test socket-2.2 {tcp connection with client port specified} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket -server accept 2828]
	proc accept {file addr port} {
            global x
................................................................................
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} [list ready "hello $port"]
test socket-2.3 {tcp connection with client interface specified} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket  -server accept 2828]
	proc accept {file addr port} {
            global x
................................................................................
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} {ready {hello 127.0.0.1}}
test socket-2.4 {tcp connection with server interface specified} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket -server accept -myaddr [info hostname] 2828]
	proc accept {file addr port} {
            global x
................................................................................
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} {ready hello}
test socket-2.5 {tcp connection with redundant server port} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket -server accept 2828]
	proc accept {file addr port} {
            global x
................................................................................
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} {ready hello}
test socket-2.6 {tcp connection} {} {
    set status ok
    if {![catch {set sock [socket 127.0.0.1 2828]}]} {
	if {![catch {gets $sock}]} {
	    set status broken
	}
	close $sock
    }
    set status
} ok
test socket-2.7 {echo server, one line} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
	set f [socket -server accept 2828]
	proc accept {s a p} {
            fileevent $s readable [list echo $s]
................................................................................
    puts $s "hello abcdefghijklmnop"
    set x [gets $s]
    close $s
    set y [gets $f]
    close $f
    list $x $y
} {{hello abcdefghijklmnop} done}
test socket-2.8 {echo server, loop 50 times, single connection} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set f [socket -server accept 2828]
	proc accept {s a p} {
            fileevent $s readable [list echo $s]
            fconfigure $s -buffering line
................................................................................
	}
    }
    close $s
    catch {set x [gets $f]}
    close $f
    set x
} {done 50}
test socket-2.9 {socket conflict} {stdio} {
    set s [socket -server accept 2828]
    removeFile script
    set f [open script w]
    puts -nonewline $f {socket -server accept 2828}
    close $f
    set f [open "|[list $tcltest script]" r]
    gets $f
................................................................................
    set x [list [catch {close $f} msg] $msg]
    close $s
    set x
} {1 {couldn't open socket: address already in use
    while executing
"socket -server accept 2828"
    (file "script" line 1)}}
test socket-2.10 {close on accept, accepted socket lives} {
    set done 0
    set timer [after 20000 "set done timed_out"]
    set ss [socket -server accept 2830]
    proc accept {s a p} {
	global ss
	close $ss
	fileevent $s readable "readit $s"
................................................................................
    set cs [socket [info hostname] 2830]
    puts $cs hello
    close $cs
    vwait done
    after cancel $timer
    set done
} 1
test socket-2.11 {detecting new data} {
    proc accept {s a p} {
	global sock
	set sock $s
    }

    set s [socket -server accept 2400]
    set sock ""
................................................................................
    close $s2
    close $s
    close $sock
    set result
} {one {} two}


test socket-3.1 {socket conflict} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set f [socket -server accept 2828]
	puts ready
	gets stdin
	close $f
................................................................................
    gets $f
    set x [list [catch {socket -server accept 2828} msg] \
		$msg]
    puts $f bye
    close $f
    set x
} {1 {couldn't open socket: address already in use}}
test socket-3.2 {server with several clients} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set t1 [after 30000 "set x timed_out"]
	set t2 [after 31000 "set x timed_out"]
	set t3 [after 32000 "set x timed_out"]
	set counter 0
................................................................................
    close $s2
    close $s3
    lappend x [gets $f]
    close $f
    set x
} {ready done}

test socket-4.1 {server with several clients} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	gets stdin
	set s [socket 127.0.0.1 2828]
	fconfigure $s -buffering line
	for {set i 0} {$i < 100} {incr i} {
................................................................................
    puts $p2 bye
    puts $p3 bye
    close $p1
    close $p2
    close $p3
    set l
} {{p1 bye done} {p2 bye done} {p3 bye done}}
test socket-4.2 {byte order problems, socket numbers, htons} {
    set x ok
    if {[catch {socket -server dodo 0x3000} msg]} {
	set x $msg
    } else {
	close $msg
    }
    set x
} ok

test socket-5.1 {byte order problems, socket numbers, htons} {unixOnly} {
    #
    # THIS TEST WILL FAIL if you are running as superuser.
    #

    set x {couldn't open socket: not owner}
    if {![catch {socket -server dodo 0x1} msg]} {
        set x {htons problem, should be disallowed, are you running as SU?}
	close $msg
    }
    set x
} {couldn't open socket: not owner}
test socket-5.2 {byte order problems, socket numbers, htons} {
    set x {couldn't open socket: port number too high}
    if {![catch {socket -server dodo 0x10000} msg]} {
	set x {port resolution problem, should be disallowed}
	close $msg
    }
    set x
} {couldn't open socket: port number too high}
test socket-5.3 {byte order problems, socket numbers, htons} {unixOnly} {
    #
    # THIS TEST WILL FAIL if you are running as superuser.
    #

    set x {couldn't open socket: not owner}
    if {![catch {socket -server dodo 21} msg]} {
	set x {htons problem, should be disallowed, are you running as SU?}
	close $msg
    }
    set x
} {couldn't open socket: not owner}

test socket-6.1 {accept callback error} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	gets stdin
	socket 127.0.0.1 2848
    }
    close $f
................................................................................
    vwait x
    after cancel $timer
    close $s
    rename bgerror {}
    set x
} {{divide by zero}}

test socket-7.1 {testing socket specific options} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	socket -server accept 2820
	proc accept args {
	    global x
	    set x done
................................................................................
    close $s
    close $f
    set l ""
    lappend l [string compare [lindex $p 0] 127.0.0.1]
    lappend l [string compare [lindex $p 2] 2820]
    lappend l [llength $p]
} {0 0 3}
test socket-7.2 {testing socket specific options} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	socket -server accept 2821
	proc accept args {
	    global x
	    set x done
................................................................................
    close $s
    close $f
    set l ""
    lappend l [llength $p]
    lappend l [lindex $p 0]
    lappend l [expr [lindex $p 2] == 2821]
} {3 127.0.0.1 0}
test socket-7.3 {testing socket specific options} {
    set s [socket -server accept 2822]
    set l [fconfigure $s]
    close $s
    update
    llength $l
} 12
test socket-7.4 {testing socket specific options} {
    set s [socket -server accept 2823]
    proc accept {s a p} {
	global x
	set x [fconfigure $s -sockname]
	close $s
    }
    set s1 [socket [info hostname] 2823]
................................................................................
    vwait x
    after cancel $timer
    close $s
    close $s1
    set l ""
    lappend l [lindex $x 2] [llength $x]
} {2823 3}
test socket-7.5 {testing socket specific options} {unixOrPc} {
    set s [socket -server accept 2829]
    proc accept {s a p} {
	global x
	set x [fconfigure $s -sockname]
	close $s
    }
    set s1 [socket 127.0.0.1 2829]
................................................................................
    after cancel $timer
    close $s
    close $s1
    set l ""
    lappend l [lindex $x 0] [lindex $x 2] [llength $x]
} {127.0.0.1 2829 3}

test socket-8.1 {testing -async flag on sockets} {
    # NOTE: This test may fail on some Solaris 2.4 systems. If it does,
    # check that you have these patches installed (using showrev -p):
    #
    # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03,
    # 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01,
    # 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03,
    # 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01,
................................................................................
    vwait x
    set z [gets $s1]
    close $s
    close $s1
    set z
} bye

test socket-9.1 {testing spurious events} {
    set len 0
    set spurious 0
    set done 0
    proc readlittle {s} {
	global spurious done len
	set l [read $s 1]
	if {[string length $l] == 0} {
................................................................................
    close $c
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    close $s
    list $spurious $len
} {0 50}
test socket-9.2 {testing async write, fileevents, flush on close} {} {
    set firstblock ""
    for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
    set secondblock ""
    for {set i 0} {$i < 16} {incr i} {
	set secondblock "b$secondblock$secondblock"
    }
    set l [socket -server accept 2832]
................................................................................
    fileevent $s readable "readit $s"
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    close $l
    set count
} 65566
test socket-9.3 {testing EOF stickyness} {
    proc count_to_eof {s} {
	global count done timer
	set l [gets $s]
	if {[eof $s]} {
	    incr count
	    if {$count > 9} {
		close $s
................................................................................
    vwait done
    close $s
    set count
} {eof is sticky}

removeFile script

test socket-10.1 {testing socket accept callback error handling} {
    set goterror 0
    proc bgerror args {global goterror; set goterror 1}
    set s [socket -server accept 2898]
    proc accept {s a p} {close $s; error}
    set c [socket 127.0.0.1 2898]
    vwait goterror
    close $s
    close $c
    set goterror
} 1

test socket-11.1 {tcp connection} {doTestsWithRemoteServer} {
    sendCommand {
	set socket9_1_test_server [socket -server accept 2834]
	proc accept {s a p} {
	    puts $s done
	    close $s
	}
    }
    set s [socket $remoteServerIP 2834]
    set r [gets $s]
    close $s
    sendCommand {close $socket9_1_test_server}
    set r
} done
test socket-11.2 {client specifies its port} {doTestsWithRemoteServer} {
    if {[info exists port]} {
	incr port
    } else {
	set port [expr 2048 + [pid]%1024]
    }
    sendCommand {
	set socket9_2_test_server [socket -server accept 2835]
................................................................................
    if {$r == $port} {
	set result ok
    } else {
	set result broken
    }
    set result
} ok
test socket-11.3 {trying to connect, no server} {doTestsWithRemoteServer} {
    set status ok
    if {![catch {set s [socket $remoteServerIp 2836]}]} {
	if {![catch {gets $s}]} {
	    set status broken
	}
	close $s
    }
    set status
} ok
test socket-11.4 {remote echo, one line} {doTestsWithRemoteServer} {
    sendCommand {
	set socket10_6_test_server [socket -server accept 2836]
	proc accept {s a p} {
	    fileevent $s readable [list echo $s]
	    fconfigure $s -buffering line -translation crlf
	}
	proc echo {s} {
................................................................................
    fconfigure $f -translation crlf -buffering line
    puts $f hello
    set r [gets $f]
    close $f
    sendCommand {close $socket10_6_test_server}
    set r
} hello
test socket-11.5 {remote echo, 50 lines} {doTestsWithRemoteServer} {
    sendCommand {
	set socket10_7_test_server [socket -server accept 2836]
	proc accept {s a p} {
	    fileevent $s readable [list echo $s]
	    fconfigure $s -buffering line -translation crlf
	}
	proc echo {s} {
................................................................................
} 50
# Macintosh sockets can have more than one server per port
if {$tcl_platform(platform) == "macintosh"} {
    set conflictResult {0 2836}
} else {
    set conflictResult {1 {couldn't open socket: address already in use}}
}
test socket-11.6 {socket conflict} {doTestsWithRemoteServer} {
    set s1 [socket -server accept 2836]
    if {[catch {set s2 [socket -server accept 2836]} msg]} {
	set result [list 1 $msg]
    } else {
	set result [list 0 [lindex [fconfigure $s2 -sockname] 2]]
	close $s2
    }
    close $s1
    set result
} $conflictResult
test socket-11.7 {server with several clients} {doTestsWithRemoteServer} {
    sendCommand {
	set socket10_9_test_server [socket -server accept 2836]
	proc accept {s a p} {
	    fconfigure $s -buffering line
	    fileevent $s readable [list echo $s]
	}
	proc echo {s} {
................................................................................
    }
    close $s1
    close $s2
    close $s3
    sendCommand {close $socket10_9_test_server}
    set i
} 100    
test socket-11.8 {client with several servers} {doTestsWithRemoteServer} {
    sendCommand {
	set s1 [socket -server "accept 4003" 4003]
	set s2 [socket -server "accept 4004" 4004]
	set s3 [socket -server "accept 4005" 4005]
	proc accept {mp s a p} {
	    puts $s $mp
	    close $s
................................................................................
    sendCommand {
	close $s1
	close $s2
	close $s3
    }
    set l
} {4003 {} 1 4004 {} 1 4005 {} 1}
test socket-11.9 {accept callback error} {doTestsWithRemoteServer} {
    set s [socket -server accept 2836]
    proc accept {s a p} {expr 10 / 0}
    proc bgerror args {
	global x
	set x $args
    }
    if {[catch {sendCommand {
................................................................................
    set timer [after 10000 "set x timed_out"]
    vwait x
    after cancel $timer
    close $s
    rename bgerror {}
    set x
} {{divide by zero}}
test socket-11.10 {testing socket specific options} {doTestsWithRemoteServer} {
    sendCommand {
	set socket10_12_test_server [socket -server accept 2836]
	proc accept {s a p} {close $s}
    }
    set s [socket $remoteServerIP 2836]
    set p [fconfigure $s -peername]
    set n [fconfigure $s -sockname]
    set l ""
    lappend l [lindex $p 2] [llength $p] [llength $p]
    close $s
    sendCommand {close $socket10_12_test_server}
    set l
} {2836 3 3}
test socket-11.11 {testing spurious events} {doTestsWithRemoteServer} {
    sendCommand {
	set socket10_13_test_server [socket -server accept 2836]
	proc accept {s a p} {
	    fconfigure $s -translation "auto lf"
	    after 100 writesome $s
	}
	proc writesome {s} {
................................................................................
    fileevent $c readable "readlittle $c"
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    sendCommand {close $socket10_13_test_server}
    list $spurious $len
} {0 2690}
test socket-11.12 {testing EOF stickyness} {doTestsWithRemoteServer} {
    set counter 0
    set done 0
    proc count_up {s} {
	global counter done after_id
	set l [gets $s]
	if {[eof $s]} {
	    incr counter
................................................................................
    fileevent $c readable "count_up $c"
    set after_id [after 1000 timed_out]
    vwait done
    sendCommand {close $socket10_14_test_server}
    set done
} {EOF is sticky}
test socket-11.13 {testing async write, async flush, async close} \
	{doTestsWithRemoteServer} {
    proc readit {s} {
	global count done
	set l [read $s]
	incr count [string length $l]
	if {[eof $s]} {
	    close $s
	    set done 1
................................................................................
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    sendCommand {close $l}
    set count
} 65566

test socket-12.1 {testing inheritance of server sockets} {doTestsWithRemoteServer} {

    removeFile script1
    removeFile script2

    # Script1 is just a 10 second delay.  If the server socket
    # is inherited, it will be held open for 10 seconds

    set f [open script1 w]
................................................................................
	set x {server socket was inherited}
    }

    removeFile script1
    removeFile script2
    set x
} {server socket was not inherited}
test socket-12.2 {testing inheritance of client sockets} {doTestsWithRemoteServer} {

    removeFile script1
    removeFile script2

    # Script1 is just a 10 second delay.  If the server socket
    # is inherited, it will be held open for 10 seconds

    set f [open script1 w]
................................................................................
    if {!$failed} {
	vwait failed
    }
    removeFile script1
    removeFile script2
    set x
} {client socket was not inherited}
test socket-12.3 {testing inheritance of accepted sockets} {doTestsWithRemoteServer} {

    removeFile script1
    removeFile script2

    set f [open script1 w]
    puts $f {
	after 10000 exit
	vwait forever
................................................................................
# cleanup
if {[string match sock* $commandSocket] == 1} {
   puts $commandSocket exit
   flush $commandSocket
}
catch {close $commandSocket}
catch {close $remoteProcChan}
::test::cleanupTests
flush stdout

















|







 







|



<
<
<
<
<







 







<
<
<







 







|

>
|
|
<







 







|


|




|


|




|


|


|




|


|


|




|




|



|







 







|







 







|







 







|







 







|







 







|









|







 







|







 







|







 







|







 







|







 







|







 







|







 







|







 







|









|
<
<
<
>







|







|
<
<
<
>








|







 







|







 







|







 







|






|







 







|







 







|







 







|







 







|







 







|







 







|











|













|







 







|









|







 







|







 







|










|







 







|







 







|







 







|













|







 







|







 







|







 







|
>







 







|
>







 







|
>







 







|

>

>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
58
59
60
61
62
63
64
65
66
67
68





69
70
71
72
73
74
75
...
110
111
112
113
114
115
116



117
118
119
120
121
122
123
...
139
140
141
142
143
144
145
146
147
148
149
150

151
152
153
154
155
156
157
...
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
...
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
...
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
...
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
...
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
...
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
...
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
...
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
...
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
...
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
...
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
...
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
...
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
...
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
...
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
...
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
...
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
...
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
...
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
...
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
...
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
...
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
....
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
....
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
....
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
....
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
....
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
....
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
....
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
1243
....
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
....
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
....
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
....
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
....
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
....
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
#
# 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.
#
# RCS: @(#) $Id: socket.test,v 1.1.2.7 1999/03/23 20:06:54 hershey Exp $

# Running socket tests with a remote server:
# ------------------------------------------
# 
# Some tests in socket.test depend on the existence of a remote server to
# which they connect. The remote server must be an instance of tcltest and it
# must run the script found in the file "remote.tcl" in this directory. You
................................................................................
# either in Tcl or in the environment; if they are, it attempts to connect to
# 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 {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}






#
# If remoteServerIP or remoteServerPort are not set, check in the
# environment variables for externally set values.
#

if {![info exists remoteServerIP]} {
    if {[info exists env(remoteServerIP)]} {
................................................................................
if {$doTestsWithRemoteServer} {
    catch {close $commandSocket}
    if {[catch {set commandSocket [socket $remoteServerIP \
						$remoteServerPort]}] != 0} {
	if {[info commands exec] == ""} {
	    set noRemoteTestReason "can't exec"
	    set doTestsWithRemoteServer 0



	} else {
	    set remoteServerIP 127.0.0.1
	    set remoteFile [file join [pwd] remote.tcl]
	    if {[catch {set remoteProcChan \
				[open "|[list $tcltest $remoteFile \
					-serverIsSilent \
					-port $remoteServerPort \
................................................................................
	}
    } else {
	fconfigure $commandSocket -translation crlf -buffering line
    }
}

# Some tests are run only if we are doing testing against a remote server.
set ::tcltest::testConfig(doTestsWithRemoteServer) $doTestsWithRemoteServer
if {$doTestsWithRemoteServer == 0} {
    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"
    }
}

#
# If we do the tests, define a command to send a command to the
# remote server.
................................................................................
	    } else {
		append resp $line "\n"
	    }
	}
    }
}

test socket-1.1 {arg parsing for socket command} {socket} {
    list [catch {socket -server} msg] $msg
} {1 {no argument given for -server option}}
test socket-1.2 {arg parsing for socket command} {socket} {
    list [catch {socket -server foo} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.3 {arg parsing for socket command} {socket} {
    list [catch {socket -myaddr} msg] $msg
} {1 {no argument given for -myaddr option}}
test socket-1.4 {arg parsing for socket command} {socket} {
    list [catch {socket -myaddr 127.0.0.1} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.5 {arg parsing for socket command} {socket} {
    list [catch {socket -myport} msg] $msg
} {1 {no argument given for -myport option}}
test socket-1.6 {arg parsing for socket command} {socket} {
    list [catch {socket -myport xxxx} msg] $msg
} {1 {expected integer but got "xxxx"}}
test socket-1.7 {arg parsing for socket command} {socket} {
    list [catch {socket -myport 2522} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.8 {arg parsing for socket command} {socket} {
    list [catch {socket -froboz} msg] $msg
} {1 {bad option "-froboz": must be -async, -myaddr, -myport, or -server}}
test socket-1.9 {arg parsing for socket command} {socket} {
    list [catch {socket -server foo -myport 2521 3333} msg] $msg
} {1 {Option -myport is not valid for servers}}
test socket-1.10 {arg parsing for socket command} {socket} {
    list [catch {socket host 2528 -junk} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.11 {arg parsing for socket command} {socket} {
    list [catch {socket -server callback 2520 --} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.12 {arg parsing for socket command} {socket} {
    list [catch {socket foo badport} msg] $msg
} {1 {expected integer but got "badport"}}

test socket-2.1 {tcp connection} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x timed_out"]
	set f [socket -server accept 2828]
	proc accept {file addr port} {
	    global x
................................................................................
} {ready done {}}

if [info exists port] {
    incr port
} else { 
    set port [expr 2048 + [pid]%1024]
}
test socket-2.2 {tcp connection with client port specified} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket -server accept 2828]
	proc accept {file addr port} {
            global x
................................................................................
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} [list ready "hello $port"]
test socket-2.3 {tcp connection with client interface specified} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket  -server accept 2828]
	proc accept {file addr port} {
            global x
................................................................................
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} {ready {hello 127.0.0.1}}
test socket-2.4 {tcp connection with server interface specified} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket -server accept -myaddr [info hostname] 2828]
	proc accept {file addr port} {
            global x
................................................................................
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} {ready hello}
test socket-2.5 {tcp connection with redundant server port} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket -server accept 2828]
	proc accept {file addr port} {
            global x
................................................................................
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} {ready hello}
test socket-2.6 {tcp connection} {socket} {
    set status ok
    if {![catch {set sock [socket 127.0.0.1 2828]}]} {
	if {![catch {gets $sock}]} {
	    set status broken
	}
	close $sock
    }
    set status
} ok
test socket-2.7 {echo server, one line} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
	set f [socket -server accept 2828]
	proc accept {s a p} {
            fileevent $s readable [list echo $s]
................................................................................
    puts $s "hello abcdefghijklmnop"
    set x [gets $s]
    close $s
    set y [gets $f]
    close $f
    list $x $y
} {{hello abcdefghijklmnop} done}
test socket-2.8 {echo server, loop 50 times, single connection} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set f [socket -server accept 2828]
	proc accept {s a p} {
            fileevent $s readable [list echo $s]
            fconfigure $s -buffering line
................................................................................
	}
    }
    close $s
    catch {set x [gets $f]}
    close $f
    set x
} {done 50}
test socket-2.9 {socket conflict} {socket stdio} {
    set s [socket -server accept 2828]
    removeFile script
    set f [open script w]
    puts -nonewline $f {socket -server accept 2828}
    close $f
    set f [open "|[list $tcltest script]" r]
    gets $f
................................................................................
    set x [list [catch {close $f} msg] $msg]
    close $s
    set x
} {1 {couldn't open socket: address already in use
    while executing
"socket -server accept 2828"
    (file "script" line 1)}}
test socket-2.10 {close on accept, accepted socket lives} {socket} {
    set done 0
    set timer [after 20000 "set done timed_out"]
    set ss [socket -server accept 2830]
    proc accept {s a p} {
	global ss
	close $ss
	fileevent $s readable "readit $s"
................................................................................
    set cs [socket [info hostname] 2830]
    puts $cs hello
    close $cs
    vwait done
    after cancel $timer
    set done
} 1
test socket-2.11 {detecting new data} {socket} {
    proc accept {s a p} {
	global sock
	set sock $s
    }

    set s [socket -server accept 2400]
    set sock ""
................................................................................
    close $s2
    close $s
    close $sock
    set result
} {one {} two}


test socket-3.1 {socket conflict} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set f [socket -server accept 2828]
	puts ready
	gets stdin
	close $f
................................................................................
    gets $f
    set x [list [catch {socket -server accept 2828} msg] \
		$msg]
    puts $f bye
    close $f
    set x
} {1 {couldn't open socket: address already in use}}
test socket-3.2 {server with several clients} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set t1 [after 30000 "set x timed_out"]
	set t2 [after 31000 "set x timed_out"]
	set t3 [after 32000 "set x timed_out"]
	set counter 0
................................................................................
    close $s2
    close $s3
    lappend x [gets $f]
    close $f
    set x
} {ready done}

test socket-4.1 {server with several clients} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	gets stdin
	set s [socket 127.0.0.1 2828]
	fconfigure $s -buffering line
	for {set i 0} {$i < 100} {incr i} {
................................................................................
    puts $p2 bye
    puts $p3 bye
    close $p1
    close $p2
    close $p3
    set l
} {{p1 bye done} {p2 bye done} {p3 bye done}}
test socket-4.2 {byte order problems, socket numbers, htons} {socket} {
    set x ok
    if {[catch {socket -server dodo 0x3000} msg]} {
	set x $msg
    } else {
	close $msg
    }
    set x
} ok

test socket-5.1 {byte order problems, socket numbers, htons} \



	{socket unixOnly notRoot} {
    set x {couldn't open socket: not owner}
    if {![catch {socket -server dodo 0x1} msg]} {
        set x {htons problem, should be disallowed, are you running as SU?}
	close $msg
    }
    set x
} {couldn't open socket: not owner}
test socket-5.2 {byte order problems, socket numbers, htons} {socket} {
    set x {couldn't open socket: port number too high}
    if {![catch {socket -server dodo 0x10000} msg]} {
	set x {port resolution problem, should be disallowed}
	close $msg
    }
    set x
} {couldn't open socket: port number too high}
test socket-5.3 {byte order problems, socket numbers, htons} \



	{socket unixOnly notRoot} {
    set x {couldn't open socket: not owner}
    if {![catch {socket -server dodo 21} msg]} {
	set x {htons problem, should be disallowed, are you running as SU?}
	close $msg
    }
    set x
} {couldn't open socket: not owner}

test socket-6.1 {accept callback error} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	gets stdin
	socket 127.0.0.1 2848
    }
    close $f
................................................................................
    vwait x
    after cancel $timer
    close $s
    rename bgerror {}
    set x
} {{divide by zero}}

test socket-7.1 {testing socket specific options} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	socket -server accept 2820
	proc accept args {
	    global x
	    set x done
................................................................................
    close $s
    close $f
    set l ""
    lappend l [string compare [lindex $p 0] 127.0.0.1]
    lappend l [string compare [lindex $p 2] 2820]
    lappend l [llength $p]
} {0 0 3}
test socket-7.2 {testing socket specific options} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	socket -server accept 2821
	proc accept args {
	    global x
	    set x done
................................................................................
    close $s
    close $f
    set l ""
    lappend l [llength $p]
    lappend l [lindex $p 0]
    lappend l [expr [lindex $p 2] == 2821]
} {3 127.0.0.1 0}
test socket-7.3 {testing socket specific options} {socket} {
    set s [socket -server accept 2822]
    set l [fconfigure $s]
    close $s
    update
    llength $l
} 12
test socket-7.4 {testing socket specific options} {socket} {
    set s [socket -server accept 2823]
    proc accept {s a p} {
	global x
	set x [fconfigure $s -sockname]
	close $s
    }
    set s1 [socket [info hostname] 2823]
................................................................................
    vwait x
    after cancel $timer
    close $s
    close $s1
    set l ""
    lappend l [lindex $x 2] [llength $x]
} {2823 3}
test socket-7.5 {testing socket specific options} {socket unixOrPc} {
    set s [socket -server accept 2829]
    proc accept {s a p} {
	global x
	set x [fconfigure $s -sockname]
	close $s
    }
    set s1 [socket 127.0.0.1 2829]
................................................................................
    after cancel $timer
    close $s
    close $s1
    set l ""
    lappend l [lindex $x 0] [lindex $x 2] [llength $x]
} {127.0.0.1 2829 3}

test socket-8.1 {testing -async flag on sockets} {socket} {
    # NOTE: This test may fail on some Solaris 2.4 systems. If it does,
    # check that you have these patches installed (using showrev -p):
    #
    # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03,
    # 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01,
    # 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03,
    # 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01,
................................................................................
    vwait x
    set z [gets $s1]
    close $s
    close $s1
    set z
} bye

test socket-9.1 {testing spurious events} {socket} {
    set len 0
    set spurious 0
    set done 0
    proc readlittle {s} {
	global spurious done len
	set l [read $s 1]
	if {[string length $l] == 0} {
................................................................................
    close $c
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    close $s
    list $spurious $len
} {0 50}
test socket-9.2 {testing async write, fileevents, flush on close} {socket} {
    set firstblock ""
    for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
    set secondblock ""
    for {set i 0} {$i < 16} {incr i} {
	set secondblock "b$secondblock$secondblock"
    }
    set l [socket -server accept 2832]
................................................................................
    fileevent $s readable "readit $s"
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    close $l
    set count
} 65566
test socket-9.3 {testing EOF stickyness} {socket} {
    proc count_to_eof {s} {
	global count done timer
	set l [gets $s]
	if {[eof $s]} {
	    incr count
	    if {$count > 9} {
		close $s
................................................................................
    vwait done
    close $s
    set count
} {eof is sticky}

removeFile script

test socket-10.1 {testing socket accept callback error handling} {socket} {
    set goterror 0
    proc bgerror args {global goterror; set goterror 1}
    set s [socket -server accept 2898]
    proc accept {s a p} {close $s; error}
    set c [socket 127.0.0.1 2898]
    vwait goterror
    close $s
    close $c
    set goterror
} 1

test socket-11.1 {tcp connection} {socket doTestsWithRemoteServer} {
    sendCommand {
	set socket9_1_test_server [socket -server accept 2834]
	proc accept {s a p} {
	    puts $s done
	    close $s
	}
    }
    set s [socket $remoteServerIP 2834]
    set r [gets $s]
    close $s
    sendCommand {close $socket9_1_test_server}
    set r
} done
test socket-11.2 {client specifies its port} {socket doTestsWithRemoteServer} {
    if {[info exists port]} {
	incr port
    } else {
	set port [expr 2048 + [pid]%1024]
    }
    sendCommand {
	set socket9_2_test_server [socket -server accept 2835]
................................................................................
    if {$r == $port} {
	set result ok
    } else {
	set result broken
    }
    set result
} ok
test socket-11.3 {trying to connect, no server} {socket doTestsWithRemoteServer} {
    set status ok
    if {![catch {set s [socket $remoteServerIp 2836]}]} {
	if {![catch {gets $s}]} {
	    set status broken
	}
	close $s
    }
    set status
} ok
test socket-11.4 {remote echo, one line} {socket doTestsWithRemoteServer} {
    sendCommand {
	set socket10_6_test_server [socket -server accept 2836]
	proc accept {s a p} {
	    fileevent $s readable [list echo $s]
	    fconfigure $s -buffering line -translation crlf
	}
	proc echo {s} {
................................................................................
    fconfigure $f -translation crlf -buffering line
    puts $f hello
    set r [gets $f]
    close $f
    sendCommand {close $socket10_6_test_server}
    set r
} hello
test socket-11.5 {remote echo, 50 lines} {socket doTestsWithRemoteServer} {
    sendCommand {
	set socket10_7_test_server [socket -server accept 2836]
	proc accept {s a p} {
	    fileevent $s readable [list echo $s]
	    fconfigure $s -buffering line -translation crlf
	}
	proc echo {s} {
................................................................................
} 50
# Macintosh sockets can have more than one server per port
if {$tcl_platform(platform) == "macintosh"} {
    set conflictResult {0 2836}
} else {
    set conflictResult {1 {couldn't open socket: address already in use}}
}
test socket-11.6 {socket conflict} {socket doTestsWithRemoteServer} {
    set s1 [socket -server accept 2836]
    if {[catch {set s2 [socket -server accept 2836]} msg]} {
	set result [list 1 $msg]
    } else {
	set result [list 0 [lindex [fconfigure $s2 -sockname] 2]]
	close $s2
    }
    close $s1
    set result
} $conflictResult
test socket-11.7 {server with several clients} {socket doTestsWithRemoteServer} {
    sendCommand {
	set socket10_9_test_server [socket -server accept 2836]
	proc accept {s a p} {
	    fconfigure $s -buffering line
	    fileevent $s readable [list echo $s]
	}
	proc echo {s} {
................................................................................
    }
    close $s1
    close $s2
    close $s3
    sendCommand {close $socket10_9_test_server}
    set i
} 100    
test socket-11.8 {client with several servers} {socket doTestsWithRemoteServer} {
    sendCommand {
	set s1 [socket -server "accept 4003" 4003]
	set s2 [socket -server "accept 4004" 4004]
	set s3 [socket -server "accept 4005" 4005]
	proc accept {mp s a p} {
	    puts $s $mp
	    close $s
................................................................................
    sendCommand {
	close $s1
	close $s2
	close $s3
    }
    set l
} {4003 {} 1 4004 {} 1 4005 {} 1}
test socket-11.9 {accept callback error} {socket doTestsWithRemoteServer} {
    set s [socket -server accept 2836]
    proc accept {s a p} {expr 10 / 0}
    proc bgerror args {
	global x
	set x $args
    }
    if {[catch {sendCommand {
................................................................................
    set timer [after 10000 "set x timed_out"]
    vwait x
    after cancel $timer
    close $s
    rename bgerror {}
    set x
} {{divide by zero}}
test socket-11.10 {testing socket specific options} {socket doTestsWithRemoteServer} {
    sendCommand {
	set socket10_12_test_server [socket -server accept 2836]
	proc accept {s a p} {close $s}
    }
    set s [socket $remoteServerIP 2836]
    set p [fconfigure $s -peername]
    set n [fconfigure $s -sockname]
    set l ""
    lappend l [lindex $p 2] [llength $p] [llength $p]
    close $s
    sendCommand {close $socket10_12_test_server}
    set l
} {2836 3 3}
test socket-11.11 {testing spurious events} {socket doTestsWithRemoteServer} {
    sendCommand {
	set socket10_13_test_server [socket -server accept 2836]
	proc accept {s a p} {
	    fconfigure $s -translation "auto lf"
	    after 100 writesome $s
	}
	proc writesome {s} {
................................................................................
    fileevent $c readable "readlittle $c"
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    sendCommand {close $socket10_13_test_server}
    list $spurious $len
} {0 2690}
test socket-11.12 {testing EOF stickyness} {socket doTestsWithRemoteServer} {
    set counter 0
    set done 0
    proc count_up {s} {
	global counter done after_id
	set l [gets $s]
	if {[eof $s]} {
	    incr counter
................................................................................
    fileevent $c readable "count_up $c"
    set after_id [after 1000 timed_out]
    vwait done
    sendCommand {close $socket10_14_test_server}
    set done
} {EOF is sticky}
test socket-11.13 {testing async write, async flush, async close} \
	{socket doTestsWithRemoteServer} {
    proc readit {s} {
	global count done
	set l [read $s]
	incr count [string length $l]
	if {[eof $s]} {
	    close $s
	    set done 1
................................................................................
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    sendCommand {close $l}
    set count
} 65566

test socket-12.1 {testing inheritance of server sockets} \
	{socket doTestsWithRemoteServer} {
    removeFile script1
    removeFile script2

    # Script1 is just a 10 second delay.  If the server socket
    # is inherited, it will be held open for 10 seconds

    set f [open script1 w]
................................................................................
	set x {server socket was inherited}
    }

    removeFile script1
    removeFile script2
    set x
} {server socket was not inherited}
test socket-12.2 {testing inheritance of client sockets} \
	{socket doTestsWithRemoteServer} {
    removeFile script1
    removeFile script2

    # Script1 is just a 10 second delay.  If the server socket
    # is inherited, it will be held open for 10 seconds

    set f [open script1 w]
................................................................................
    if {!$failed} {
	vwait failed
    }
    removeFile script1
    removeFile script2
    set x
} {client socket was not inherited}
test socket-12.3 {testing inheritance of accepted sockets} \
	{socket doTestsWithRemoteServer} {
    removeFile script1
    removeFile script2

    set f [open script1 w]
    puts $f {
	after 10000 exit
	vwait forever
................................................................................
# cleanup
if {[string match sock* $commandSocket] == 1} {
   puts $commandSocket exit
   flush $commandSocket
}
catch {close $commandSocket}
catch {close $remoteProcChan}
::tcltest::cleanupTests
flush stdout
return










Changes to tests/source.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
176
177
178
179
180
181
182
183
184
185
186










# 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.
#
# RCS: @(#) $Id: source.test,v 1.1.2.3 1999/03/11 18:50:09 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test source-1.1 {source command} {
    set x "old x value"
    set y "old y value"
    set z "old z value"
................................................................................
    set x {}
    makeFile [list set x "a b\0c"] source.file
    source source.file
    string length $x
} 5

# cleanup
catch {::test::removeFile source.file}
::test::cleanupTests
return

















|

|







 







|
|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
# 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.
#
# RCS: @(#) $Id: source.test,v 1.1.2.4 1999/03/23 20:06:55 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test source-1.1 {source command} {
    set x "old x value"
    set y "old y value"
    set z "old z value"
................................................................................
    set x {}
    makeFile [list set x "a b\0c"] source.file
    source source.file
    string length $x
} 5

# cleanup
catch {::tcltest::removeFile source.file}
::tcltest::cleanupTests
return











Changes to tests/split.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
64
65
66
67
68
69
70
71
72
73










# 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.
#
# RCS: @(#) $Id: split.test,v 1.1.2.2 1999/03/11 18:50:09 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

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} {
................................................................................
    list [catch split msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
test split-2.2 {split errors} {
    list [catch {split a b c} msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
# 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.
#
# RCS: @(#) $Id: split.test,v 1.1.2.3 1999/03/23 20:06:55 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

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} {
................................................................................
    list [catch split msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
test split-2.2 {split errors} {
    list [catch {split a b c} msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/stack.test.

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










# 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.
#
# RCS: @(#) $Id: stack.test,v 1.1.2.1 1999/03/11 18:50:10 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Note that a failure in this test results in a crash of the executable.

test stack-1.1 {maxNestingDepth reached on infinite recursion} {
    proc recurse {} { return [recurse] }
    catch {recurse} rv
    rename recurse {}
    set rv
} {too many nested calls to Tcl_EvalObj (infinite loop?)}

# cleanup
::test::cleanupTests
return

















|

|













|


>
>
>
>
>
>
>
>
>
>
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
# 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.
#
# RCS: @(#) $Id: stack.test,v 1.1.2.2 1999/03/23 20:06:56 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Note that a failure in this test results in a crash of the executable.

test stack-1.1 {maxNestingDepth reached on infinite recursion} {
    proc recurse {} { return [recurse] }
    catch {recurse} rv
    rename recurse {}
    set rv
} {too many nested calls to Tcl_EvalObj (infinite loop?)}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/string.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
383
384
385
386
387
388
389
390
391
392










# 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.
#
# RCS: @(#) $Id: string.test,v 1.1.2.3 1999/03/11 18:50:11 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test string-1.1 {string compare} {
    string compare abcde abdef
} -1
test string-1.2 {string compare} {
................................................................................
    list [catch {string gorp a b} msg] $msg
} {1 {bad option "gorp": must be compare, first, index, last, length, match, range, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}}
test string-15.2 {error conditions} {
    list [catch {string} msg] $msg
} {1 {wrong # args: should be "string option arg ?arg ...?"}}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
# 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.
#
# RCS: @(#) $Id: string.test,v 1.1.2.4 1999/03/23 20:06:56 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test string-1.1 {string compare} {
    string compare abcde abdef
} -1
test string-1.2 {string compare} {
................................................................................
    list [catch {string gorp a b} msg] $msg
} {1 {bad option "gorp": must be compare, first, index, last, length, match, range, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}}
test string-15.2 {error conditions} {
    list [catch {string} msg] $msg
} {1 {wrong # args: should be "string option arg ?arg ...?"}}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/stringObj.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
...
188
189
190
191
192
193
194
195
196
197










#
# 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.
#
# RCS: @(#) $Id: stringObj.test,v 1.1.2.3 1999/03/11 18:50:11 hershey Exp $

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test stringObj-1.1 {string type registration} {
    set t [testobj types]
    set first [string first "string" $t]
    set result [expr {$first != -1}]
................................................................................
	    [teststringobj length 2] [teststringobj length2 2] \
	    [teststringobj get 2]
} {5 10 5 5 abcde}

testobj freeallvars

# cleanup
::test::cleanupTests
return

















|







|







 







|


>
>
>
>
>
>
>
>
>
>
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
...
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
#
# 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.
#
# RCS: @(#) $Id: stringObj.test,v 1.1.2.4 1999/03/23 20:06:57 hershey Exp $

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test stringObj-1.1 {string type registration} {
    set t [testobj types]
    set first [string first "string" $t]
    set result [expr {$first != -1}]
................................................................................
	    [teststringobj length 2] [teststringobj length2 2] \
	    [teststringobj get 2]
} {5 10 5 5 abcde}

testobj freeallvars

# cleanup
::tcltest::cleanupTests
return











Changes to tests/subst.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
105
106
107
108
109
110
111
112
113
114










# Copyright (c) 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.
#
# RCS: @(#) $Id: subst.test,v 1.1.2.3 1999/03/11 18:50:11 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test subst-1.1 {basics} {
    list [catch {subst} msg] $msg
} {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}}
test subst-1.2 {basics} {
................................................................................
} {abc $x 3 \A}
test subst-7.7 {switches} {
    set x 123
    subst -nov -nob -noc {abc $x [expr 1+2] \\\x41}
} {abc $x [expr 1+2] \\\x41}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
# Copyright (c) 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.
#
# RCS: @(#) $Id: subst.test,v 1.1.2.4 1999/03/23 20:06:57 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test subst-1.1 {basics} {
    list [catch {subst} msg] $msg
} {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}}
test subst-1.2 {basics} {
................................................................................
} {abc $x 3 \A}
test subst-7.7 {switches} {
    set x 123
    subst -nov -nob -noc {abc $x [expr 1+2] \\\x41}
} {abc $x [expr 1+2] \\\x41}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/switch.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
178
179
180
181
182
183
184
185
186
187










# 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.
#
# RCS: @(#) $Id: switch.test,v 1.1.2.4 1999/03/11 18:50:12 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test switch-1.1 {simple patterns} {
    switch a a {format 1} b {format 2} c {format 3} default {format 4}
} 1
test switch-1.2 {simple patterns} {
................................................................................
    	1 {set msg 1}
        2 {}
        default {set msg 2}
    }
} {}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
# 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.
#
# RCS: @(#) $Id: switch.test,v 1.1.2.5 1999/03/23 20:06:58 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test switch-1.1 {simple patterns} {
    switch a a {format 1} b {format 2} c {format 3} default {format 4}
} 1
test switch-1.2 {simple patterns} {
................................................................................
    	1 {set msg 1}
        2 {}
        default {set msg 2}
    }
} {}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/thread.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
...
216
217
218
219
220
221
222
223
224
225










#
# 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.
#
# RCS: @(#) $Id: thread.test,v 1.1.2.2 1999/03/11 18:50:12 hershey Exp $

if {[info command testthread] == ""} {
    puts "skipping: tests require the testthread command"
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set mainthread [testthread names]
proc ThreadReap {} {
    global mainthread
    testthread errorproc ThreadNullError
................................................................................
    set serverthread [testthread create]
    set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg]
    list $x $msg $errorCode
} {1 ERR CODE}
ThreadReap

# cleanup
::test::cleanupTests
return

















|






|







 







|


>
>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
...
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
#
# 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.
#
# RCS: @(#) $Id: thread.test,v 1.1.2.3 1999/03/23 20:06:58 hershey Exp $

if {[info command testthread] == ""} {
    puts "skipping: tests require the testthread command"
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set mainthread [testthread names]
proc ThreadReap {} {
    global mainthread
    testthread errorproc ThreadNullError
................................................................................
    set serverthread [testthread create]
    set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg]
    list $x $msg $errorCode
} {1 ERR CODE}
ThreadReap

# cleanup
::tcltest::cleanupTests
return











Changes to tests/timer.test.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
534
535
536
537
538
539
540
541
542
543










#
# 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.
#
# RCS: @(#) $Id: timer.test,v 1.1.2.3 1999/03/11 18:50:13 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test timer-1.1 {Tcl_CreateTimerHandler procedure} {
    foreach i [after info] {
	after cancel $i
    }
................................................................................
    set x before
    after 300
    update
    set x
} {before after2 after4}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
#
# 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.
#
# RCS: @(#) $Id: timer.test,v 1.1.2.4 1999/03/23 20:06:58 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test timer-1.1 {Tcl_CreateTimerHandler procedure} {
    foreach i [after info] {
	after cancel $i
    }
................................................................................
    set x before
    after 300
    update
    set x
} {before after2 after4}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/trace.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
964
965
966
967
968
969
970
971
972
973










# 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.
#
# RCS: @(#) $Id: trace.test,v 1.1.2.3 1999/03/11 18:50:13 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc traceScalar {name1 name2 op} {
    global info
    set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg]
}
................................................................................
# Delete arrays when done, so they can be re-used as scalars
# elsewhere.

catch {unset x}
catch {unset y}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
# 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.
#
# RCS: @(#) $Id: trace.test,v 1.1.2.4 1999/03/23 20:06:59 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc traceScalar {name1 name2 op} {
    global info
    set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg]
}
................................................................................
# Delete arrays when done, so they can be re-used as scalars
# elsewhere.

catch {unset x}
catch {unset y}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/unixFCmd.test.

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
..
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
...
266
267
268
269
270
271
272
273
274
275










# 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.
#
# RCS: @(#) $Id: unixFCmd.test,v 1.1.2.4 1999/03/11 18:50:14 hershey Exp $

if {$tcl_platform(platform) != "unix"} {
    puts "skipping: Unix only tests..."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {$user == "root"} {
    puts "Skipping unixFCmd tests.  They depend on not being able to write to"
    puts "certain directories.  It would be too dangerous to run them as root."
    return






}

proc openup {path} {
    testchmod 777 $path
    if {[file isdirectory $path]} {
	catch {
	    foreach p [glob [file join $path *]] {
................................................................................
		openup $file
		file delete -force -- $file
	    }
	}
    }
}

test unixFCmd-1.1 {TclpRenameFile: EACCES} {
    cleanup
    file mkdir td1/td2/td3
    exec chmod 000 td1/td2
    set msg [list [catch {file rename td1/td2/td3 td2} msg] $msg]
    exec chmod 755 td1/td2
    set msg
} {1 {error renaming "td1/td2/td3": permission denied}}
test unixFCmd-1.2 {TclpRenameFile: EEXIST} {
    cleanup
    file mkdir td1/td2
    file mkdir td2
    list [catch {file rename td2 td1} msg] $msg
} {1 {error renaming "td2" to "td1/td2": file already exists}}
test unixFCmd-1.3 {TclpRenameFile: EINVAL} {
    cleanup
    file mkdir td1
    list [catch {file rename td1 td1} msg] $msg
} {1 {error renaming "td1" to "td1/td1": trying to rename a volume or move a directory into itself}}
test unixFCmd-1.4 {TclpRenameFile: EISDIR} {
    # can't make it happen
} {}
test unixFCmd-1.5 {TclpRenameFile: ENOENT} {
    cleanup
    file mkdir td1
    list [catch {file rename td2 td1} msg] $msg
} {1 {error renaming "td2": no such file or directory}}
test unixFCmd-1.6 {TclpRenameFile: ENOTDIR} {
    # can't make it happen
} {}
test unixFCmd-1.7 {TclpRenameFile: EXDEV} {
    cleanup
    file mkdir foo/bar
    file attr foo -perm 040555
    set msg [list [catch {file rename foo/bar /tmp} msg] $msg]
    catch {file delete /tmp/bar}
    catch {file attr foo -perm 040777}
    catch {file delete -force foo}
    set msg
} {1 {can't unlink "foo/bar": permission denied}}
test unixFCmd-1.8 {Checking EINTR Bug} nonPortable {
    testalarm 
    after 2000
    list [testgotsig] [testgotsig]
} {1 0}
test unixFCmd-1.9 {Checking EINTR Bug} nonPortable {
    cleanup
    set f [open tfalarm w]
    puts $f {
	after 2000
	puts "hello world"
	exit 0
    }
................................................................................
    close $f
    testalarm 
    set pipe [open "|[info nameofexecutable] tfalarm" r+]
    set line [read $pipe 1]
    catch {close $pipe}
    list $line [testgotsig]
} {h 1}
test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} {

    cleanup
    exec touch tf1
    exec touch tf2
    file copy -force tf1 tf2
} {}
test unixFCmd-2.2 {TclpCopyFile: src is symlink} {
    cleanup
    exec ln -s tf1 tf2
    file copy tf2 tf3
    file type tf3
} {link}
test unixFCmd-2.3 {TclpCopyFile: src is block} {
    cleanup
    set null "/dev/null"
    while {[file type $null] != "characterSpecial"} {
	set null [file join [file dirname $null] [file readlink $null]]
    }
    # file copy $null tf1
} {}
test unixFCmd-2.4 {TclpCopyFile: src is fifo} {
    cleanup
    if [catch {exec mknod tf1 p}] {
	list 1
    } else {
	file copy tf1 tf2
	expr {"[file type tf1]" == "[file type tf2]"}
    }
} {1}
test unixFCmd-2.5 {TclpCopyFile: copy attributes} {
    cleanup
    exec touch tf1
    exec chmod 472 tf1
    file copy tf1 tf2
    string range [exec ls -l tf2] 0 9
} {-r--rwx-w-}

test unixFCmd-3.1 {CopyFile not done} {
} {}

test unixFCmd-4.1 {TclpDeleteFile not done} {
} {}

test unixFCmd-5.1 {TclpCreateDirectory not done} {
} {}

test unixFCmd-6.1 {TclpCopyDirectory not done} {
} {}

test unixFCmd-7.1 {TclpRemoveDirectory not done} {
} {}

test unixFCmd-8.1 {TraverseUnixTree not done} {
} {}

test unixFCmd-9.1 {TraversalCopy not done} {
} {}

test unixFCmd-10.1 {TraversalDelete not done} {
} {}

test unixFCmd-11.1 {CopyFileAttrs not done} {
} {}

set ::test::testConfig(tclGroup) 0
if {[catch {exec {groups}} groupList] == 0} {
    if {[lsearch $groupList tcl] != -1} {
	set ::test::testConfig(tclGroup) 1
    }
}

test unixFCmd-12.1 {GetGroupAttribute - file not found} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -group} msg] $msg
} {1 {could not read "foo.test": no such file or directory}}
test unixFCmd-12.2 {GetGroupAttribute - file found} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]
    list [catch {file attributes foo.test -group}] [file delete -force -- foo.test]
} {0 {}}

test unixFCmd-13.1 {GetOwnerAttribute - file not found} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -group} msg] $msg
} {1 {could not read "foo.test": no such file or directory}}
test unixFCmd-13.2 {GetOwnerAttribute} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]

    list [catch {file attributes foo.test -owner} msg] [string compare $msg $user] [file delete -force -- foo.test]
} {0 0 {}}

test unixFCmd-14.1 {GetPermissionsAttribute - file not found} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -permissions} msg] $msg
} {1 {could not read "foo.test": no such file or directory}}
test unixFCmd-14.2 {GetPermissionsAttribute} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]
    list [catch {file attribute foo.test -permissions}] [file delete -force -- foo.test]

} {0 {}}










#groups hard to test
test unixFCmd-15.1 {SetGroupAttribute - invalid group} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -group foozzz} msg] $msg [file delete -force -- foo.test]

} {1 {could not set group for file "foo.test": group "foozzz" does not exist} {}}
test unixFCmd-15.2 {SetGroupAttribute - invalid file} {tclGroup} {

    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -group tcl} msg] $msg
} {1 {could not set group for file "foo.test": no such file or directory}}

#changing owners hard to do
test unixFCmd-16.1 {SetOwnerAttribute - current owner} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]

    list [catch {file attributes foo.test -owner $user} msg] $msg [string compare [file attributes foo.test -owner] $user] [file delete -force -- foo.test]

} {0 {} 0 {}}
test unixFCmd-16.2 {SetOwnerAttribute - invalid file} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -owner $user} msg] $msg
} {1 {could not set owner for file "foo.test": no such file or directory}}
test unixFCmd-16.3 {SetOwnerAttribute - invalid owner} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -owner foozzz} msg] $msg
} {1 {could not set owner for file "foo.test": user "foozzz" does not exist}}


test unixFCmd-17.1 {SetPermissionsAttribute} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]
    list [catch {file attributes foo.test -permissions 0000} msg] $msg [file attributes foo.test -permissions] [file delete -force -- foo.test]


} {0 {} 00000 {}}
test unixFCmd-17.2 {SetPermissionsAttribute} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -permissions 0000} msg] $msg
} {1 {could not set permissions for file "foo.test": no such file or directory}}
test unixFCmd-17.3 {SetPermissionsAttribute} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]
    list [catch {file attributes foo.test -permissions foo} msg] $msg [file delete -force -- foo.test]

} {1 {expected integer but got "foo"} {}}
test unixFCmd-18.1 {Unix pwd} {nonPortable} {
    # This test is nonportable because SunOS generates a weird error
    # message when the current directory isn't readable.
    set cd [pwd]
    set nd $cd/tstdir
    file mkdir $nd
    cd $nd
    exec chmod 000 $nd
................................................................................
    exec chmod 755 $nd
    file delete $nd
    set r
} {1 {error getting working directory name:}}

# cleanup
cleanup
::test::cleanupTests
return

















|

<
<
<
<
<
|



|
|
|
|
>
>
>
>
>
>







 







|







|





|




|


|




|


|









|




|







 







|
>





|





|







|








|







|


|


|


|


|


|


|


|


|


<
<
<
<
<
<
<
|









|



|


>
|


|



|


|
>


>
>
>
>
>
>
>
>
>

|

|
>

|
>

|



|


>
|
>

|



|





|


|
>
>

|



|


|
>

|







 







|


>
>
>
>
>
>
>
>
>
>
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
..
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
...
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
# 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.
#
# RCS: @(#) $Id: unixFCmd.test,v 1.1.2.5 1999/03/23 20:07:00 hershey Exp $






if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Several tests require need to match results against the unix username
set user {}
if {$tcl_platform(platform) == "unix"} {
    catch {set user [exec whoami]}
    if {$user == ""} {
	catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
    }
    if {$user == ""} {
	set user "root"
    }
}

proc openup {path} {
    testchmod 777 $path
    if {[file isdirectory $path]} {
	catch {
	    foreach p [glob [file join $path *]] {
................................................................................
		openup $file
		file delete -force -- $file
	    }
	}
    }
}

test unixFCmd-1.1 {TclpRenameFile: EACCES} {unixOnly notRoot} {
    cleanup
    file mkdir td1/td2/td3
    exec chmod 000 td1/td2
    set msg [list [catch {file rename td1/td2/td3 td2} msg] $msg]
    exec chmod 755 td1/td2
    set msg
} {1 {error renaming "td1/td2/td3": permission denied}}
test unixFCmd-1.2 {TclpRenameFile: EEXIST} {unixOnly notRoot} {
    cleanup
    file mkdir td1/td2
    file mkdir td2
    list [catch {file rename td2 td1} msg] $msg
} {1 {error renaming "td2" to "td1/td2": file already exists}}
test unixFCmd-1.3 {TclpRenameFile: EINVAL} {unixOnly notRoot} {
    cleanup
    file mkdir td1
    list [catch {file rename td1 td1} msg] $msg
} {1 {error renaming "td1" to "td1/td1": trying to rename a volume or move a directory into itself}}
test unixFCmd-1.4 {TclpRenameFile: EISDIR} {unixOnly notRoot} {
    # can't make it happen
} {}
test unixFCmd-1.5 {TclpRenameFile: ENOENT} {unixOnly notRoot} {
    cleanup
    file mkdir td1
    list [catch {file rename td2 td1} msg] $msg
} {1 {error renaming "td2": no such file or directory}}
test unixFCmd-1.6 {TclpRenameFile: ENOTDIR} {emptyTest unixOnly notRoot} {
    # can't make it happen
} {}
test unixFCmd-1.7 {TclpRenameFile: EXDEV} {unixOnly notRoot} {
    cleanup
    file mkdir foo/bar
    file attr foo -perm 040555
    set msg [list [catch {file rename foo/bar /tmp} msg] $msg]
    catch {file delete /tmp/bar}
    catch {file attr foo -perm 040777}
    catch {file delete -force foo}
    set msg
} {1 {can't unlink "foo/bar": permission denied}}
test unixFCmd-1.8 {Checking EINTR Bug} {unixOnly notRoot nonPortable} {
    testalarm 
    after 2000
    list [testgotsig] [testgotsig]
} {1 0}
test unixFCmd-1.9 {Checking EINTR Bug} {unixOnly notRoot nonPortable} {
    cleanup
    set f [open tfalarm w]
    puts $f {
	after 2000
	puts "hello world"
	exit 0
    }
................................................................................
    close $f
    testalarm 
    set pipe [open "|[info nameofexecutable] tfalarm" r+]
    set line [read $pipe 1]
    catch {close $pipe}
    list $line [testgotsig]
} {h 1}
test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} \
	{unixOnly notRoot} {
    cleanup
    exec touch tf1
    exec touch tf2
    file copy -force tf1 tf2
} {}
test unixFCmd-2.2 {TclpCopyFile: src is symlink} {unixOnly notRoot} {
    cleanup
    exec ln -s tf1 tf2
    file copy tf2 tf3
    file type tf3
} {link}
test unixFCmd-2.3 {TclpCopyFile: src is block} {unixOnly notRoot} {
    cleanup
    set null "/dev/null"
    while {[file type $null] != "characterSpecial"} {
	set null [file join [file dirname $null] [file readlink $null]]
    }
    # file copy $null tf1
} {}
test unixFCmd-2.4 {TclpCopyFile: src is fifo} {unixOnly notRoot} {
    cleanup
    if [catch {exec mknod tf1 p}] {
	list 1
    } else {
	file copy tf1 tf2
	expr {"[file type tf1]" == "[file type tf2]"}
    }
} {1}
test unixFCmd-2.5 {TclpCopyFile: copy attributes} {unixOnly notRoot} {
    cleanup
    exec touch tf1
    exec chmod 472 tf1
    file copy tf1 tf2
    string range [exec ls -l tf2] 0 9
} {-r--rwx-w-}

test unixFCmd-3.1 {CopyFile not done} {emptyTest unixOnly notRoot} {
} {}

test unixFCmd-4.1 {TclpDeleteFile not done} {emptyTest unixOnly notRoot} {
} {}

test unixFCmd-5.1 {TclpCreateDirectory not done} {emptyTest unixOnly notRoot} {
} {}

test unixFCmd-6.1 {TclpCopyDirectory not done} {emptyTest unixOnly notRoot} {
} {}

test unixFCmd-7.1 {TclpRemoveDirectory not done} {emptyTest unixOnly notRoot} {
} {}

test unixFCmd-8.1 {TraverseUnixTree not done} {emptyTest unixOnly notRoot} {
} {}

test unixFCmd-9.1 {TraversalCopy not done} {emptyTest unixOnly notRoot} {
} {}

test unixFCmd-10.1 {TraversalDelete not done} {emptyTest unixOnly notRoot} {
} {}

test unixFCmd-11.1 {CopyFileAttrs not done} {emptyTest unixOnly notRoot} {
} {}








test unixFCmd-12.1 {GetGroupAttribute - file not found} {unixOnly notRoot} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -group} msg] $msg
} {1 {could not read "foo.test": no such file or directory}}
test unixFCmd-12.2 {GetGroupAttribute - file found} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]
    list [catch {file attributes foo.test -group}] [file delete -force -- foo.test]
} {0 {}}

test unixFCmd-13.1 {GetOwnerAttribute - file not found} {unixOnly notRoot} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -group} msg] $msg
} {1 {could not read "foo.test": no such file or directory}}
test unixFCmd-13.2 {GetOwnerAttribute} {unixOnly notRoot} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]
    list [catch {file attributes foo.test -owner} msg] \
	    [string compare $msg $user] [file delete -force -- foo.test]
} {0 0 {}}

test unixFCmd-14.1 {GetPermissionsAttribute - file not found} {unixOnly notRoot} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -permissions} msg] $msg
} {1 {could not read "foo.test": no such file or directory}}
test unixFCmd-14.2 {GetPermissionsAttribute} {unixOnly notRoot} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]
    list [catch {file attribute foo.test -permissions}] \
	    [file delete -force -- foo.test]
} {0 {}}

# Find a group that exists on this system, or else skip tests that require
# groups
set ::tcltest::testConfig(foundGroup) 0
catch {
    set groupList [exec groups]
    set group [lindex $groupList 0]
    set ::tcltest::testConfig(foundGroup) 1
}

#groups hard to test
test unixFCmd-15.1 {SetGroupAttribute - invalid group} {unixOnly notRoot} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -group foozzz} msg] \
	    $msg [file delete -force -- foo.test]
} {1 {could not set group for file "foo.test": group "foozzz" does not exist} {}}
test unixFCmd-15.2 {SetGroupAttribute - invalid file} \
	{unixOnly notRoot foundGroup} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -group $group} msg] $msg
} {1 {could not set group for file "foo.test": no such file or directory}}

#changing owners hard to do
test unixFCmd-16.1 {SetOwnerAttribute - current owner} {unixOnly notRoot} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]
    list [catch {file attributes foo.test -owner $user} msg] \
	    $msg [string compare [file attributes foo.test -owner] $user] \
	    [file delete -force -- foo.test]
} {0 {} 0 {}}
test unixFCmd-16.2 {SetOwnerAttribute - invalid file} {unixOnly notRoot} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -owner $user} msg] $msg
} {1 {could not set owner for file "foo.test": no such file or directory}}
test unixFCmd-16.3 {SetOwnerAttribute - invalid owner} {unixOnly notRoot} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -owner foozzz} msg] $msg
} {1 {could not set owner for file "foo.test": user "foozzz" does not exist}}


test unixFCmd-17.1 {SetPermissionsAttribute} {unixOnly notRoot} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]
    list [catch {file attributes foo.test -permissions 0000} msg] \
	    $msg [file attributes foo.test -permissions] \
	    [file delete -force -- foo.test]
} {0 {} 00000 {}}
test unixFCmd-17.2 {SetPermissionsAttribute} {unixOnly notRoot} {
    catch {file delete -force -- foo.test}
    list [catch {file attributes foo.test -permissions 0000} msg] $msg
} {1 {could not set permissions for file "foo.test": no such file or directory}}
test unixFCmd-17.3 {SetPermissionsAttribute} {unixOnly notRoot} {
    catch {file delete -force -- foo.test}
    close [open foo.test w]
    list [catch {file attributes foo.test -permissions foo} msg] $msg \
	    [file delete -force -- foo.test]
} {1 {expected integer but got "foo"} {}}
test unixFCmd-18.1 {Unix pwd} {nonPortable unixOnly notRoot} {
    # This test is nonportable because SunOS generates a weird error
    # message when the current directory isn't readable.
    set cd [pwd]
    set nd $cd/tstdir
    file mkdir $nd
    cd $nd
    exec chmod 000 $nd
................................................................................
    exec chmod 755 $nd
    file delete $nd
    set r
} {1 {error getting working directory name:}}

# cleanup
cleanup
::tcltest::cleanupTests
return











Changes to tests/unixFile.test.

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










# 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.
#
# RCS: @(#) $Id: unixFile.test,v 1.1.2.2 1999/03/11 18:50:14 hershey Exp $

if {$tcl_platform(platform) != "unix"} {
    puts "skipping: Unix only tests..."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testfindexecutable\""
    puts "command, so I can't test the Tcl_FindExecutable function"
    return
}


set oldPath $env(PATH)
close [open junk w]
file attributes junk -perm 0777

set absPath [file join [pwd] junk]


test unixFile-1.1 {Tcl_FindExecutable} {
    set env(PATH) ""
    testfindexecutable junk
} $absPath
test unixFile-1.2 {Tcl_FindExecutable} {
    set env(PATH) "/dummy"
    testfindexecutable junk
} {}
test unixFile-1.3 {Tcl_FindExecutable} {
    set env(PATH) "/dummy:[pwd]"
    testfindexecutable junk
} $absPath
test unixFile-1.4 {Tcl_FindExecutable} {
    set env(PATH) "/dummy:"
    testfindexecutable junk
} $absPath
test unixFile-1.5 {Tcl_FindExecutable} {
    set env(PATH) "/dummy:/dummy"
    testfindexecutable junk
} {}
test unixFile-1.6 {Tcl_FindExecutable} {
    set env(PATH) "/dummy::/dummy"
    testfindexecutable junk
} $absPath
test unixFile-1.7 {Tcl_FindExecutable} {
    set env(PATH) ":/dummy"
    testfindexecutable junk
} $absPath

# cleanup
set env(PATH) $oldPath
file delete junk
::test::cleanupTests
return

















|

<
<
<
<
<
|









>
|
|
|
<
|
>
>
|



|



|



|



|



|



|





|

|


>
>
>
>
>
>
>
>
>
>
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
# 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.
#
# RCS: @(#) $Id: unixFile.test,v 1.1.2.3 1999/03/23 20:07:00 hershey Exp $






if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testfindexecutable\""
    puts "command, so I can't test the Tcl_FindExecutable function"
    return
}

catch {
    set oldPath $env(PATH)
    close [open junk w]
    file attributes junk -perm 0777

    set absPath [file join [pwd] junk]
}

test unixFile-1.1 {Tcl_FindExecutable} {unixOnly} {
    set env(PATH) ""
    testfindexecutable junk
} $absPath
test unixFile-1.2 {Tcl_FindExecutable} {unixOnly} {
    set env(PATH) "/dummy"
    testfindexecutable junk
} {}
test unixFile-1.3 {Tcl_FindExecutable} {unixOnly} {
    set env(PATH) "/dummy:[pwd]"
    testfindexecutable junk
} $absPath
test unixFile-1.4 {Tcl_FindExecutable} {unixOnly} {
    set env(PATH) "/dummy:"
    testfindexecutable junk
} $absPath
test unixFile-1.5 {Tcl_FindExecutable} {unixOnly} {
    set env(PATH) "/dummy:/dummy"
    testfindexecutable junk
} {}
test unixFile-1.6 {Tcl_FindExecutable} {unixOnly} {
    set env(PATH) "/dummy::/dummy"
    testfindexecutable junk
} $absPath
test unixFile-1.7 {Tcl_FindExecutable} {unixOnly} {
    set env(PATH) ":/dummy"
    testfindexecutable junk
} $absPath

# cleanup
catch {set env(PATH) $oldPath}
file delete junk
::tcltest::cleanupTests
return











Changes to tests/unixInit.test.

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
..
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
..
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










#
# 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.
#
# RCS: @(#) $Id: unixInit.test,v 1.1.2.4 1999/03/12 23:28:30 surles Exp $

if {$tcl_platform(platform) != "unix"} {
    puts "skipping: Unix only tests..."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {csh -c "setenv LANG japanese"}] == 0} {
    set ::test::testConfig(japanese) 1
}

catch {set oldlibrary $env(TCL_LIBRARY); unset env(TCL_LIBRARY)}
catch {set oldlang $env(LANG)}
set env(LANG) C

test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {
    set x {}

    set f [open "|[list $tcltest]" w+]
    exec kill -PIPE [pid $f]
    lappend x [catch {close $f}]

    set f [open "|[list $tcltest]" w+]
................................................................................
    fconfigure $f -buffering none
    puts $f {puts $tcl_libPath; exit}
    set path [gets $f]
    close $f
    return $path
}

test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} {
    set origDir [testgetdefenc]
    testsetdefenc slappy
    set path [testgetdefenc]
    testsetdefenc $origDir
    set path
} {slappy}
test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} {
    set path [getlibpath]

    set installLib lib/tcl[info tclversion]
    if {[string match {*[ab]*} [info patchlevel]]} {
	set developLib tcl[info patchlevel]/library
    } else {
        set developLib tcl[info tclversion]/library
................................................................................
    set prefix [file dirname [file dirname $tcltest]]

    set x {}
    lappend x [string compare [lindex $path 0] $prefix/$installLib]
    lappend x [string compare [lindex $path 1] [file dirname $prefix]/$developLib]
    set x
} {0 0}
test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} {
    # ((str != NULL) && (str[0] != '\0')) 

    set env(TCL_LIBRARY) sparkly
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lindex $path 0
} "sparkly"
test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} {
    # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0))

    set env(TCL_LIBRARY) /a/b/tcl1.7
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lrange $path 0 1
} [list /a/b/tcl1.7 /a/b/tcl[info tclversion]]
test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} {
    # Child process translates env variable from native encoding.

    set env(TCL_LIBRARY) "\xa7"
    set x [lindex [getlibpath] 0]
    unset env(TCL_LIBRARY)
    unset env(LANG)

    set x
} "\xa7"
test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} {

    # cannot test
} {}
test unixInit-2.6 {TclpInitLibraryPath: executable relative} {
    file delete -force /tmp/sparkly
    file mkdir /tmp/sparkly/bin
    file copy $tcltest /tmp/sparkly/bin/tcltest

    file mkdir /tmp/sparkly/lib/tcl[info tclversion]
    close [open /tmp/sparkly/lib/tcl[info tclversion]/init.tcl w]

    set x [lrange [getlibpath /tmp/sparkly/bin/tcltest] 0 2]
    file delete -force /tmp/sparkly
    set x
} [list /tmp/sparkly/lib/tcl[info tclversion] /tmp/tcl[info patchlevel]/library]
test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} {

    # would need test command to get defaultLibDir and compare it to
    # [lindex $auto_path end]
} {}
test unixInit-3.1 {TclpSetInitialEncodings} {
    set env(LANG) C

    set f [open "|[list $tcltest]" w+]
    fconfigure $f -buffering none
    puts $f {puts [encoding system]; exit}
    set enc [gets $f]
    close $f
    unset env(LANG)

    set enc
} {iso8859-1}
test unixInit-3.1 {TclpSetInitialEncodings} {japanese nonPortable} {
    set env(LANG) japanese

    set f [open "|[list $tcltest]" w+]
    fconfigure $f -buffering none
    puts $f {puts [encoding system]; exit}
    set enc [gets $f]
    close $f
    unset env(LANG)

    set enc
} {euc-jp}
    
test unixInit-4.1 {TclpSetVariables} {
    # just make sure they exist

    set a [list $tcl_library $tcl_pkgPath $tcl_platform(os)]
    set a [list $tcl_platform(osVersion) $tcl_platform(machine)]
    set tcl_platform(platform)
} "unix"

test unixInit-5.1 {Tcl_Init} {
    # test initScript
} {}

test unixInit-6.1 {Tcl_SourceRCFile} {
} {}
    
# cleanup
catch {unset env(TCL_LIBRARY); set env(TCL_LIBRARY) $oldlibrary}
catch {unset env(LANG); set env(LANG) $oldlang}
::test::cleanupTests
return

















|

<
<
<
<
<
|




|






|







 







|






|







 







|








|








|









|
>


|











|
>



|











|












|







|



|





|


>
>
>
>
>
>
>
>
>
>
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
..
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
..
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
#
# 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.
#
# RCS: @(#) $Id: unixInit.test,v 1.1.2.5 1999/03/23 20:07:01 hershey Exp $






if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {csh -c "setenv LANG japanese"}] == 0} {
    set ::tcltest::testConfig(japanese) 1
}

catch {set oldlibrary $env(TCL_LIBRARY); unset env(TCL_LIBRARY)}
catch {set oldlang $env(LANG)}
set env(LANG) C

test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unixOnly} {
    set x {}

    set f [open "|[list $tcltest]" w+]
    exec kill -PIPE [pid $f]
    lappend x [catch {close $f}]

    set f [open "|[list $tcltest]" w+]
................................................................................
    fconfigure $f -buffering none
    puts $f {puts $tcl_libPath; exit}
    set path [gets $f]
    close $f
    return $path
}

test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} {unixOnly} {
    set origDir [testgetdefenc]
    testsetdefenc slappy
    set path [testgetdefenc]
    testsetdefenc $origDir
    set path
} {slappy}
test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} {unixOnly} {
    set path [getlibpath]

    set installLib lib/tcl[info tclversion]
    if {[string match {*[ab]*} [info patchlevel]]} {
	set developLib tcl[info patchlevel]/library
    } else {
        set developLib tcl[info tclversion]/library
................................................................................
    set prefix [file dirname [file dirname $tcltest]]

    set x {}
    lappend x [string compare [lindex $path 0] $prefix/$installLib]
    lappend x [string compare [lindex $path 1] [file dirname $prefix]/$developLib]
    set x
} {0 0}
test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} {unixOnly} {
    # ((str != NULL) && (str[0] != '\0')) 

    set env(TCL_LIBRARY) sparkly
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lindex $path 0
} "sparkly"
test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} {unixOnly} {
    # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0))

    set env(TCL_LIBRARY) /a/b/tcl1.7
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lrange $path 0 1
} [list /a/b/tcl1.7 /a/b/tcl[info tclversion]]
test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} {unixOnly} {
    # Child process translates env variable from native encoding.

    set env(TCL_LIBRARY) "\xa7"
    set x [lindex [getlibpath] 0]
    unset env(TCL_LIBRARY)
    unset env(LANG)

    set x
} "\xa7"
test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} \
	{emptyTest unixOnly} {
    # cannot test
} {}
test unixInit-2.6 {TclpInitLibraryPath: executable relative} {unixOnly} {
    file delete -force /tmp/sparkly
    file mkdir /tmp/sparkly/bin
    file copy $tcltest /tmp/sparkly/bin/tcltest

    file mkdir /tmp/sparkly/lib/tcl[info tclversion]
    close [open /tmp/sparkly/lib/tcl[info tclversion]/init.tcl w]

    set x [lrange [getlibpath /tmp/sparkly/bin/tcltest] 0 2]
    file delete -force /tmp/sparkly
    set x
} [list /tmp/sparkly/lib/tcl[info tclversion] /tmp/tcl[info patchlevel]/library]
test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} \
	{emptyTest unixOnly} {
    # would need test command to get defaultLibDir and compare it to
    # [lindex $auto_path end]
} {}
test unixInit-3.1 {TclpSetInitialEncodings} {unixOnly} {
    set env(LANG) C

    set f [open "|[list $tcltest]" w+]
    fconfigure $f -buffering none
    puts $f {puts [encoding system]; exit}
    set enc [gets $f]
    close $f
    unset env(LANG)

    set enc
} {iso8859-1}
test unixInit-3.1 {TclpSetInitialEncodings} {unixOnly japanese nonPortable} {
    set env(LANG) japanese

    set f [open "|[list $tcltest]" w+]
    fconfigure $f -buffering none
    puts $f {puts [encoding system]; exit}
    set enc [gets $f]
    close $f
    unset env(LANG)

    set enc
} {euc-jp}
    
test unixInit-4.1 {TclpSetVariables} {unixOnly} {
    # just make sure they exist

    set a [list $tcl_library $tcl_pkgPath $tcl_platform(os)]
    set a [list $tcl_platform(osVersion) $tcl_platform(machine)]
    set tcl_platform(platform)
} "unix"

test unixInit-5.1 {Tcl_Init} {emptyTest unixOnly} {
    # test initScript
} {}

test unixInit-6.1 {Tcl_SourceRCFile} {emptyTest unixOnly} {
} {}
    
# cleanup
catch {unset env(TCL_LIBRARY); set env(TCL_LIBRARY) $oldlibrary}
catch {unset env(LANG); set env(LANG) $oldlang}
::tcltest::cleanupTests
return











Changes to tests/unixNotfy.test.

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
..
50
51
52
53
54
55
56
57
58
59










#
# 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.
#
# RCS: @(#) $Id: unixNotfy.test,v 1.1.2.3 1999/03/11 18:50:15 hershey Exp $

if {$tcl_platform(platform) != "unix"} {
    puts "skipping: Unix only tests..."
    return
}

# The tests should not be run if you have a notifier which is unable to
# detect infinite vwaits, as the tests below will hang. The presence of
# the "testthread" command indicates that this is the case.

if {"[info commands testthread]" == "testthread"} {
    puts "skipping: tests require the testthread command..."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test unixNotfy-1.1 {Tcl_DeleteFileHandler} {
    catch {vwait x}
    set f [open foo w]
    fileevent $f writable {set x 1}
    vwait x
    close $f
    list [catch {vwait x} msg] $msg
} {1 {can't wait for variable "x":  would wait forever}}
test unixNotfy-1.2 {Tcl_DeleteFileHandler} {
    catch {vwait x}
    set f1 [open foo w]
    set f2 [open foo2 w]
    fileevent $f1 writable {set x 1}
    fileevent $f2 writable {set y 1}
    vwait x
    close $f1
................................................................................
    close $f2
    list [catch {vwait x} msg] $msg
} {1 {can't wait for variable "x":  would wait forever}}

# cleanup
file delete foo
file delete foo2
::test::cleanupTests
return

















|
<
<
<
<
<










|



|







|







 







|


>
>
>
>
>
>
>
>
>
>
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
..
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
#
# 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.
#
# RCS: @(#) $Id: unixNotfy.test,v 1.1.2.4 1999/03/23 20:07:01 hershey Exp $






# The tests should not be run if you have a notifier which is unable to
# detect infinite vwaits, as the tests below will hang. The presence of
# the "testthread" command indicates that this is the case.

if {"[info commands testthread]" == "testthread"} {
    puts "skipping: tests require the testthread command..."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test unixNotfy-1.1 {Tcl_DeleteFileHandler} {unixOnly} {
    catch {vwait x}
    set f [open foo w]
    fileevent $f writable {set x 1}
    vwait x
    close $f
    list [catch {vwait x} msg] $msg
} {1 {can't wait for variable "x":  would wait forever}}
test unixNotfy-1.2 {Tcl_DeleteFileHandler} {unixOnly} {
    catch {vwait x}
    set f1 [open foo w]
    set f2 [open foo2 w]
    fileevent $f1 writable {set x 1}
    fileevent $f2 writable {set y 1}
    vwait x
    close $f1
................................................................................
    close $f2
    list [catch {vwait x} msg] $msg
} {1 {can't wait for variable "x":  would wait forever}}

# cleanup
file delete foo
file delete foo2
::tcltest::cleanupTests
return











Changes to tests/unknown.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
58
59
60
61
62
63
64
65
66
67










# 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.
#
# RCS: @(#) $Id: unknown.test,v 1.1.2.3 1999/03/11 18:50:15 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset x}
catch {rename unknown unknown.old}

test unknown-1.1 {non-existent "unknown" command} {
................................................................................
test unknown-4.1 {errors in "unknown" procedure} {
    list [catch {non-existent a b} msg] $msg $errorCode
} {1 {unknown failed} NONE}

# cleanup
catch {rename unknown {}}
catch {rename unknown.old unknown}
::test::cleanupTests
return 

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
# 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.
#
# RCS: @(#) $Id: unknown.test,v 1.1.2.4 1999/03/23 20:07:01 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {unset x}
catch {rename unknown unknown.old}

test unknown-1.1 {non-existent "unknown" command} {
................................................................................
test unknown-4.1 {errors in "unknown" procedure} {
    list [catch {non-existent a b} msg] $msg $errorCode
} {1 {unknown failed} NONE}

# cleanup
catch {rename unknown {}}
catch {rename unknown.old unknown}
::tcltest::cleanupTests
return 











Changes to tests/uplevel.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
108
109
110
111
112
113
114
115
116
117










# 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.
#
# RCS: @(#) $Id: uplevel.test,v 1.1.2.3 1999/03/11 18:50:16 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc a {x y} {
    newset z [expr $x+$y]
    return $z
}
................................................................................
    set y [info level 1]
}
a2
test uplevel-5.1 {info level} {set x} 1
test uplevel-5.2 {info level} {set y} a3

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
# 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.
#
# RCS: @(#) $Id: uplevel.test,v 1.1.2.4 1999/03/23 20:07:02 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc a {x y} {
    newset z [expr $x+$y]
    return $z
}
................................................................................
    set y [info level 1]
}
a2
test uplevel-5.1 {info level} {set x} 1
test uplevel-5.2 {info level} {set y} a3

# cleanup
::tcltest::cleanupTests
return











Changes to tests/upvar.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
396
397
398
399
400
401
402
403
404
405










# 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.
#
# RCS: @(#) $Id: upvar.test,v 1.1.2.3 1999/03/11 18:50:17 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test upvar-1.1 {reading variables with upvar} {
    proc p1 {a b} {set c 22; set d 33; p2}
    proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
    p1 foo bar
................................................................................
	set a(b) 1234
	foo
    } {1234}
}
catch {unset a}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
# 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.
#
# RCS: @(#) $Id: upvar.test,v 1.1.2.4 1999/03/23 20:07:02 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test upvar-1.1 {reading variables with upvar} {
    proc p1 {a b} {set c 22; set d 33; p2}
    proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
    p1 foo bar
................................................................................
	set a(b) 1234
	foo
    } {1234}
}
catch {unset a}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/utf.test.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
254
255
256
257
258
259
260
261
262
263










#
# 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.
#
# RCS: @(#) $Id: utf.test,v 1.1.2.4 1999/03/11 18:50:17 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
    set x \x01
} [bytestring "\x01"]
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
................................................................................
test utf-23.1 {TclUniCharIsDigit} {
} {}

test utf-23.1 {TclUniCharIsSpace} {
} {}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
#
# 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.
#
# RCS: @(#) $Id: utf.test,v 1.1.2.5 1999/03/23 20:07:03 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
    set x \x01
} [bytestring "\x01"]
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
................................................................................
test utf-23.1 {TclUniCharIsDigit} {
} {}

test utf-23.1 {TclUniCharIsSpace} {
} {}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/util.test.

3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
285
286
287
288
289
290
291
292
293
294










#
# 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.
#
# RCS: @(#) $Id: util.test,v 1.1.2.4 1999/03/11 18:50:18 hershey Exp $

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test util-1.1 {TclFindElement procedure - binary element in middle of list} {
    lindex {0 foo\x00help 1} 1
} "foo\x00help"
test util-1.2 {TclFindElement procedure - binary element at end of list} {
................................................................................
    set tcl_precision 12
    list [catch {set tcl_precision abc} msg] $msg $tcl_precision
} {1 {can't set "tcl_precision": improper value for precision} 12}

set tcl_precision 12

# cleanup
::test::cleanupTests
return

















|







|







 







|


>
>
>
>
>
>
>
>
>
>
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
#
# 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.
#
# RCS: @(#) $Id: util.test,v 1.1.2.5 1999/03/23 20:07:03 hershey Exp $

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test util-1.1 {TclFindElement procedure - binary element in middle of list} {
    lindex {0 foo\x00help 1} 1
} "foo\x00help"
test util-1.2 {TclFindElement procedure - binary element at end of list} {
................................................................................
    set tcl_precision 12
    list [catch {set tcl_precision abc} msg] $msg $tcl_precision
} {1 {can't set "tcl_precision": improper value for precision} 12}

set tcl_precision 12

# cleanup
::tcltest::cleanupTests
return











Changes to tests/var.test.

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
...
590
591
592
593
594
595
596
597
598
599










#
# 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.
#
# RCS: @(#) $Id: var.test,v 1.1.2.5 1999/03/11 18:50:18 hershey Exp $
#

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {rename p ""}
catch {namespace delete test_ns_var}
catch {unset xx}
catch {unset x}
................................................................................
catch {unset y}
catch {unset i}
catch {unset a}
catch {unset xxxxx}
catch {unset aaaaa}

# cleanup
::test::cleanupTests
return

















|


|







 







|


>
>
>
>
>
>
>
>
>
>
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
...
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
#
# 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.
#
# RCS: @(#) $Id: var.test,v 1.1.2.6 1999/03/23 20:07:04 hershey Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

catch {rename p ""}
catch {namespace delete test_ns_var}
catch {unset xx}
catch {unset x}
................................................................................
catch {unset y}
catch {unset i}
catch {unset a}
catch {unset xxxxx}
catch {unset aaaaa}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/while-old.test.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
112
113
114
115
116
117
118
119
120
121










# 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.
#
# RCS: @(#) $Id: while-old.test,v 1.1.2.3 1999/03/11 18:50:19 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test while-old-1.1 {basic while loops} {
    set count 0
    while {$count < 10} {set count [expr $count+1]}
    set count
................................................................................
} {}
test while-old-5.2 {while return result} {
    set x 1
    while {$x} {set x 0}
} {}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
# 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.
#
# RCS: @(#) $Id: while-old.test,v 1.1.2.4 1999/03/23 20:07:04 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

test while-old-1.1 {basic while loops} {
    set count 0
    while {$count < 10} {set count [expr $count+1]}
    set count
................................................................................
} {}
test while-old-5.2 {while return result} {
    set x 1
    while {$x} {set x 0}
} {}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/while.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
602
603
604
605
606
607
608
609
610
611










#
# 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.
#
# RCS: @(#) $Id: while.test,v 1.1.2.3 1999/03/11 18:50:19 hershey Exp $

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Basic "while" operation.

catch {unset i}
catch {unset a}
................................................................................
	set a [concat $a $i]
        incr i
    }
    set a
} {1 3}

# cleanup
::test::cleanupTests
return

















|

|







 







|


>
>
>
>
>
>
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
#
# 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.
#
# RCS: @(#) $Id: while.test,v 1.1.2.4 1999/03/23 20:07:04 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# Basic "while" operation.

catch {unset i}
catch {unset a}
................................................................................
	set a [concat $a $i]
        incr i
    }
    set a
} {1 3}

# cleanup
::tcltest::cleanupTests
return











Changes to tests/winFCmd.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
..
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
..
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
...
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
...
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
...
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
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





#
# 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.
#
# RCS: @(#) $Id: winFCmd.test,v 1.1.2.4 1999/03/11 18:50:19 hershey Exp $
#

if {$tcl_platform(platform) != "windows"} {
    puts "skipping: Windows only tests..."
    return
}

if {[lsearch [namespace children] ::test] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc createfile {file {string a}} {
    set f [open $file w]
    puts -nonewline $f $string
    close $f
................................................................................
	}
	if {$x != ""} {
	    catch {eval file delete -force -- $x}
	}
    }
}

set ::test::testConfig(cdrom) 0
set ::test::testConfig(exdev) 0

# find a CD-ROM so we can test read-only filesystems.

set cdrom {}
set nodrive x:
foreach p {d e f g h i j k l m n o p q r s t u v w x y z} {
    set name ${p}:/dummy~~.fil
................................................................................
	        return $f
	    }
	}
    }
    return ""
}

if {$cdrom == ""} {
    puts "Couldn't find a CD-ROM.  Skipping tests that access CD-ROM."
    puts "If you have a CD-ROM, insert a data disk and rerun tests."
} else {
    set ::test::testConfig(cdrom) 1
    set cdfile [findfile $cdrom]
}

if {[file exists c:/] && [file exists d:/]} {
    catch {file delete d:/tf1}
    if {[catch {close [open d:/tf1 w]}] == 0} {
	file delete d:/tf1
	set ::test::testConfig(exdev) 1
    }
}

file delete -force -- td1
set foo [catch {open td1 w} testfile]
if {$foo} {
    set ::test::testConfig(longFileNames) 0
} else {
    close $testfile
    set ::test::testConfig(longFileNames) 1
    file delete -force -- td1
}

# A really long file name
# length of longname is 1216 chars, which should be greater than any static
# buffer or allowable filename.

................................................................................
append longname $longname

# Uses the "testfile" command instead of the "file" command.  The "file"
# command provides several layers of sanity checks on the arguments and
# it can be difficult to actually forward "insane" arguments to the
# low-level posix emulation layer.

test winFCmd-1.1 {TclpRenameFile: errno: EACCES} {cdrom} {
    list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} {
    cleanup
    file mkdir td1/td2/td3
    file mkdir td2
    list [catch {testfile mv td2 td1/td2} msg] $msg
} {1 EEXIST} 
test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} {!$::test::testConfig(win32s) || ("[lindex [file split [pwd]] end]" == "C:/")} {
    # Don't run this test under Win32s on a drive mounted from an NT 
    # machine; it causes the NT machine to die.

    cleanup
    list [catch {testfile mv / td1} msg] $msg
} {1 EINVAL}
test winFCmd-1.4 {TclpRenameFile: errno: EINVAL} {
    cleanup
    file mkdir td1
    list [catch {testfile mv td1 td1/td2} msg] $msg
} {1 EINVAL}
test winFCmd-1.5 {TclpRenameFile: errno: EISDIR} {
    cleanup
    file mkdir td1
    createfile tf1
    list [catch {testfile mv tf1 td1} msg] $msg
} {1 EISDIR}
test winFCmd-1.6 {TclpRenameFile: errno: ENOENT} {
    cleanup
    list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT}
test winFCmd-1.7 {TclpRenameFile: errno: ENOENT} {
    cleanup
    list [catch {testfile mv "" tf2} msg] $msg
} {1 ENOENT}
test winFCmd-1.8 {TclpRenameFile: errno: ENOENT} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 ""} msg] $msg
} {1 ENOENT}
test winFCmd-1.9 {TclpRenameFile: errno: ENOTDIR} {
    cleanup
    file mkdir td1
    createfile tf1
    list [catch {testfile mv td1 tf1} msg] $msg
} {1 ENOTDIR}
test winFCmd-1.10 {TclpRenameFile: errno: EXDEV} {exdev} {
    file delete -force d:/tf1
    file mkdir c:/tf1
    set msg [list [catch {testfile mv c:/tf1 d:/tf1} msg] $msg]
    file delete -force c:/tf1
    set msg
} {1 EXDEV}
test winFCmd-1.11 {TclpRenameFile: errno: EACCES} {
    cleanup
    set fd [open tf1 w]
    set msg [list [catch {testfile mv tf1 tf2} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
test winFCmd-1.12 {TclpRenameFile: errno: EACCES} {
    cleanup
    createfile tf1
    set fd [open tf2 w]
    set msg [list [catch {testfile mv tf1 tf2} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
test winFCmd-1.13 {TclpRenameFile: errno: EACCES} {
    cleanup
    list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.14 {TclpRenameFile: errno: EACCES} {95} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 nul} msg] $msg
} {1 EACCES}
test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {nt} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 nul} msg] $msg
} {1 EEXIST}
test winFCmd-1.16 {TclpRenameFile: MoveFile() != FALSE} {
    cleanup
    createfile tf1 tf1
    testfile mv tf1 tf2
    list [file exists tf1] [contents tf2]
} {0 tf1}
test winFCmd-1.17 {TclpRenameFile: MoveFile() == FALSE} {
    cleanup
    list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT} 
test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} {
    cleanup
    list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT} 
test winFCmd-1.19 {TclpRenameFile: errno == EACCES} {
    cleanup
    list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.20 {TclpRenameFile: src is dir} {!95} {
    # under 95, this would actually succeed and move the current dir out from 
    # under the current process!

    cleanup
    file delete /tf1
    list [catch {testfile mv [pwd] /tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.21 {TclpRenameFile: long src} {
    cleanup
    list [catch {testfile mv $longname tf1} msg] $msg
} {1 ENAMETOOLONG}
test winFCmd-1.22 {TclpRenameFile: long dst} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 $longname} msg] $msg
} {1 ENAMETOOLONG}
test winFCmd-1.23 {TclpRenameFile: move dir into self} {
    cleanup
    file mkdir td1
    list [catch {testfile mv [pwd]/td1 td1/td2} msg] $msg
} {1 EINVAL}
test winFCmd-1.24 {TclpRenameFile: move a root dir} {!$::test::testConfig(win32s) || ("[lindex [file split [pwd]] end]" == "C:/")} {
    # Don't run this test under Win32s on a drive mounted from an NT 
    # machine; it causes the NT machine to die!  Neat security hole in NT.

    cleanup
    list [catch {testfile mv / c:/} msg] $msg
} {1 EINVAL}
test winFCmd-1.25 {TclpRenameFile: cross file systems} {cdrom} {
    cleanup
    file mkdir td1
    list [catch {testfile mv td1 $cdrom/td1} msg] $msg
} {1 EXDEV} 
test winFCmd-1.26 {TclpRenameFile: readonly fs} {cdrom} {
    cleanup
    list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
test winFCmd-1.27 {TclpRenameFile: open file} {
    cleanup
    set fd [open tf1 w]
    set msg [list [catch {testfile mv tf1 tf2} msg] $msg]
    close $fd
    set msg
} {1 EACCES}    
test winFCmd-1.28 {TclpRenameFile: errno == EEXIST} {
    cleanup
    createfile tf1
    createfile tf2
    testfile mv tf1 tf2
    list [file exist tf1] [file exist tf2]
} {0 1}
test winFCmd-1.29 {TclpRenameFile: src is dir} {
    cleanup
    file mkdir td1
    createfile tf1
    list [catch {testfile mv td1 tf1} msg] $msg
} {1 ENOTDIR} 
test winFCmd-1.30 {TclpRenameFile: dst is dir} {
    cleanup
    file mkdir td1
    file mkdir td2/td2
    list [catch {testfile mv td1 td2} msg] $msg
} {1 EEXIST}
test winFCmd-1.31 {TclpRenameFile: TclpRemoveDirectory fails} {
    cleanup
    file mkdir td1
    file mkdir td2/td2
    list [catch {testfile mv td1 td2} msg] $msg
} {1 EEXIST}
test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory succeeds} {
    cleanup
    file mkdir td1/td2
    file mkdir td2
    testfile mv td1 td2
    list [file exist td1] [file exist td2] [file exist td2/td2]
} {0 1 1}
test winFCmd-1.33 {TclpRenameFile: After removing dst dir, MoveFile fails} {exdev} {

    file mkdir d:/td1
    testchmod 000 d:/td1
    set msg [list [catch {testfile mv c:/windows d:/td1} msg] $msg]
    set msg "$msg [file writable d:/td1]"
    file delete d:/td1
    set msg
} {1 EXDEV 0}
test winFCmd-1.34 {TclpRenameFile: src is dir, dst is not} {
    file mkdir td1
    createfile tf1
    list [catch {testfile mv td1 tf1} msg] $msg
} {1 ENOTDIR}
test winFCmd-1.35 {TclpRenameFile: src is not dir, dst is} {
    file mkdir td1
    createfile tf1
    list [catch {testfile mv tf1 td1} msg] $msg
} {1 EISDIR}
test winFCmd-1.36 {TclpRenameFile: src and dst not dir} {
    createfile tf1 tf1
    createfile tf2 tf2
    testfile mv tf1 tf2
    contents tf2
} {tf1}
test winFCmd-1.37 {TclpRenameFile: need to restore temp file} {
    # Can't figure out how to cause this. 
    # Need a file that can't be copied.
} {}

test winFCmd-2.1 {TclpCopyFile: errno: EACCES} {cdrom} {
    cleanup
    list [catch {testfile cp $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
test winFCmd-2.2 {TclpCopyFile: errno: EISDIR} {
    cleanup
    file mkdir td1
    list [catch {testfile cp td1 tf1} msg] $msg
} {1 EISDIR}
test winFCmd-2.3 {TclpCopyFile: errno: EISDIR} {
    cleanup
    createfile tf1
    file mkdir td1
    list [catch {testfile cp tf1 td1} msg] $msg
} {1 EISDIR}
test winFCmd-2.4 {TclpCopyFile: errno: ENOENT} {
    cleanup
    list [catch {testfile cp tf1 tf2} msg] $msg
} {1 ENOENT}
test winFCmd-2.5 {TclpCopyFile: errno: ENOENT} {
    cleanup
    list [catch {testfile cp "" tf2} msg] $msg
} {1 ENOENT}
test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} {
    cleanup
    createfile tf1
    list [catch {testfile cp tf1 ""} msg] $msg
} {1 ENOENT}
test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {!nt} {
    cleanup
    createfile tf1
    set fd [open tf2 w]
    set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
................................................................................
    cleanup
    list [catch {testfile cp nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} {95} {
    cleanup
    list [catch {testfile cp nul tf1} msg] $msg
} {1 ENOENT}
test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} {
    cleanup
    createfile tf1 tf1
    testfile cp tf1 tf2
    list [contents tf1] [contents tf2]
} {tf1 tf1}
test winFCmd-2.11 {TclpCopyFile: CopyFile succeeds} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    testfile cp tf1 tf2
    list [contents tf1] [contents tf2]
} {tf1 tf1}
test winFCmd-2.12 {TclpCopyFile: CopyFile succeeds} {
    cleanup
    createfile tf1 tf1
    testchmod 000 tf1
    testfile cp tf1 tf2
    list [contents tf2] [file writable tf2]
} {tf1 0}
test winFCmd-2.13 {TclpCopyFile: CopyFile fails} {
    cleanup
    createfile tf1
    file mkdir td1
    list [catch {testfile cp tf1 td1} msg] $msg
} {1 EISDIR} 
test winFCmd-2.14 {TclpCopyFile: errno == EACCES} {
    cleanup
    file mkdir td1
    list [catch {testfile cp td1 tf1} msg] $msg
} {1 EISDIR}
test winFCmd-2.15 {TclpCopyFile: src is directory} {
    cleanup
    file mkdir td1
    list [catch {testfile cp td1 tf1} msg] $msg
} {1 EISDIR}
test winFCmd-2.16 {TclpCopyFile: dst is directory} {
    cleanup
    createfile tf1
    file mkdir td1
    list [catch {testfile cp tf1 td1} msg] $msg
} {1 EISDIR}
test winFCmd-2.17 {TclpCopyFile: dst is readonly} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    testchmod 000 tf2
    testfile cp tf1 tf2
    list [file writable tf2] [contents tf2]
} {1 tf1}
................................................................................
    testchmod 000 tf2
    set fd [open tf2]
    set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
    close $fd
    set msg "$msg [file writable tf2]"
} {1 EACCES 0}    

test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} {cdrom} {
    list [catch {testfile rm $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
test winFCmd-3.2 {TclpDeleteFile: errno: EISDIR} {
    cleanup
    file mkdir td1
    list [catch {testfile rm td1} msg] $msg
} {1 EISDIR} 
test winFCmd-3.3 {TclpDeleteFile: errno: ENOENT} {
    cleanup
    list [catch {testfile rm tf1} msg] $msg
} {1 ENOENT}
test winFCmd-3.4 {TclpDeleteFile: errno: ENOENT} {
    cleanup
    list [catch {testfile rm ""} msg] $msg
} {1 ENOENT}
test winFCmd-3.5 {TclpDeleteFile: errno: EACCES} {
    cleanup
    set fd [open tf1 w]
    set msg [list [catch {testfile rm tf1} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
test winFCmd-3.6 {TclpDeleteFile: errno: EACCES} {
    cleanup
    list [catch {testfile rm nul} msg] $msg
} {1 EACCES}
test winFCmd-3.7 {TclpDeleteFile: DeleteFile succeeds} {
    cleanup
    createfile tf1
    testfile rm tf1
    file exist tf1
} {0}
test winFCmd-3.8 {TclpDeleteFile: DeleteFile fails} {
    cleanup
    file mkdir td1
    list [catch {testfile rm td1} msg] $msg
} {1 EISDIR}
test winFCmd-3.9 {TclpDeleteFile: errno == EACCES} {
    cleanup
    set fd [open tf1 w]
    set msg [list [catch {testfile rm tf1} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
test winFCmd-3.10 {TclpDeleteFile: path is readonly} {
    cleanup
    createfile tf1
    testchmod 000 tf1
    testfile rm tf1
    file exists tf1
} {0}
test winFCmd-3.11 {TclpDeleteFile: still can't remove path} {
    cleanup
    set fd [open tf1 w]
    testchmod 000 tf1
    set msg [list [catch {testfile rm tf1} msg] $msg]
    close $fd
    set msg
} {1 EACCES}

test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} {cdrom nt} {
    list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg
} {1 EACCES}
test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} {cdrom 95} {
    list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg
} {1 ENOSPC}
test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} {
    cleanup
    file mkdir td1
    list [catch {testfile mkdir td1} msg] $msg
} {1 EEXIST}
test winFCmd-4.4 {TclpCreateDirectory: errno: ENOENT} {
    cleanup
    list [catch {testfile mkdir td1/td2} msg] $msg
} {1 ENOENT}
test winFCmd-4.5 {TclpCreateDirectory: CreateDirectory succeeds} {
    cleanup
    testfile mkdir td1
    file type td1
} {directory}

test winFCmd-5.1 {TclpCopyDirectory: calls TraverseWinTree} {
    cleanup
    file mkdir td1
    testfile cpdir td1 td2
    list [file type td1] [file type td2]
} {directory directory}

test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} {
    cleanup
    file mkdir td1
    testchmod 000 td1
    testfile rmdir td1
    file exist td1
} {0}
test winFCmd-6.2 {TclpRemoveDirectory: errno: EEXIST} {
    cleanup
    file mkdir td1/td2
    list [catch {testfile rmdir td1} msg] $msg
} {1 {td1 EEXIST}}
test winFCmd-6.3 {TclpRemoveDirectory: errno: EACCES} {
    # can't test this w/o removing everything on your hard disk first!
    # testfile rmdir /
} {}
test winFCmd-6.4 {TclpRemoveDirectory: errno: ENOENT} {
    cleanup
    list [catch {testfile rmdir td1} msg] $msg
} {1 {td1 ENOENT}}
test winFCmd-6.5 {TclpRemoveDirectory: errno: ENOENT} {
    cleanup
    list [catch {testfile rmdir ""} msg] $msg
} {1 ENOENT}
test winFCmd-6.6 {TclpRemoveDirectory: errno: ENOTDIR} {
    cleanup
    createfile tf1
    list [catch {testfile rmdir tf1} msg] $msg
} {1 {tf1 ENOTDIR}}
test winFCmd-6.7 {TclpRemoveDirectory: RemoveDirectory succeeds} {
    cleanup
    file mkdir td1
    testfile rmdir td1
    file exists td1
} {0}
test winFCmd-6.8 {TclpRemoveDirectory: RemoveDirectory fails} {
    cleanup
    createfile tf1
    list [catch {testfile rmdir tf1} msg] $msg
} {1 {tf1 ENOTDIR}}
test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} {
    cleanup
    file mkdir td1
    testchmod 000 td1
    testfile rmdir td1
    file exists td1
} {0}
test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {!nt} {
    cleanup
    list [catch {testfile rmdir nul} msg] $msg
} {1 {nul EACCES}}
test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} {nt} {
    cleanup
    list [catch {testfile rmdir /} msg] $msg
} {1 {\ EACCES}}
test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} {!nt} {
    cleanup
    createfile tf1
    list [catch {testfile rmdir tf1} msg] $msg
} {1 {tf1 ENOTDIR}}
test winFCmd-6.13 {TclpRemoveDirectory: write-protected} {
    cleanup
    file mkdir td1
    testchmod 000 td1
    testfile rmdir td1
    file exists td1
} {0}
test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} {!nt} {
    cleanup
    file mkdir td1/td2
    list [catch {testfile rmdir td1} msg] $msg
} {1 {td1 EEXIST}}
test winFCmd-6.15 {TclpRemoveDirectory: !recursive} {
    cleanup
    file mkdir td1/td2
    list [catch {testfile rmdir td1} msg] $msg
} {1 {td1 EEXIST}}
test winFCmd-6.16 {TclpRemoveDirectory: recursive, but errno != EEXIST} {
    cleanup
    createfile tf1
    list [catch {testfile rmdir -force tf1} msg] $msg
} {1 {tf1 ENOTDIR}}
test winFCmd-6.17 {TclpRemoveDirectory: calls TraverseWinTree} {
    cleanup
    file mkdir td1/td2
    testfile rmdir -force td1
    file exists td1
} {0}

test winFCmd-7.1 {TraverseWinTree: targetPtr == NULL} {
    cleanup
    file mkdir td1/td2/td3
    testfile rmdir -force td1
    file exists td1
} {0}
test winFCmd-7.2 {TraverseWinTree: targetPtr != NULL} {
    cleanup
    file mkdir td1/td2/td3
    testfile cpdir td1 td2
    list [file exists td1] [file exists td2]
} {1 1}
test winFCmd-7.3 {TraverseWinTree: sourceAttr == -1} {
    cleanup
    list [catch {testfile cpdir td1 td2} msg] $msg
} {1 {td1 ENOENT}}
test winFCmd-7.4 {TraverseWinTree: source isn't directory} {
    cleanup
    file mkdir td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    contents td2/tf1
} {tf1}
test winFCmd-7.5 {TraverseWinTree: call TraversalCopy: DOTREE_F} {
    cleanup
    file mkdir td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    contents td2/tf1
} {tf1}
test winFCmd-7.6 {TraverseWinTree: call TraversalDelete: DOTREE_F} {
    cleanup
    file mkdir td1
    createfile td1/tf1 tf1
    testfile rmdir -force td1
    file exists td1
} {0}
test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} {
    cleanup
    file mkdir td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    contents td2/tf1
} {tf1}    
test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} {!nt && cdrom} {
    list [catch {testfile rmdir $cdrom/} msg] $msg
} "1 {$cdrom\\ EEXIST}"
test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} {nt cdrom} {
    list [catch {testfile rmdir $cdrom/} msg] $msg
} "1 {$cdrom\\ EACCES}"
test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} {

    # can't make it happen
} {}
test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} {
    cleanup
    file mkdir td1
    testchmod 000 td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    list [file exists td2] [file writable td2]
} {1 0}
test winFCmd-7.12 {TraverseWinTree: call TraversalDelete: DOTREE_PRED} {
    cleanup
    file mkdir td1
    createfile td1/tf1 tf1
    testfile rmdir -force td1
    file exists td1
} {0}
test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} {
    cleanup
    file mkdir td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    contents td2/tf1
} {tf1}    
test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} {!nt} {
    cleanup
    file mkdir td1
    list [catch {testfile cpdir td1 /} msg] $msg
} {1 {\ EEXIST}}
test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} {nt} {
    cleanup
    file mkdir td1
    list [catch {testfile cpdir td1 /} msg] $msg
} {1 {\ EACCES}}
test winFCmd-7.16 {TraverseWinTree: recurse on files: no files} {
    cleanup
    file mkdir td1
    testfile cpdir td1 td2
} {}
test winFCmd-7.17 {TraverseWinTree: recurse on files: one file} {
    cleanup
    file mkdir td1
    createfile td1/td2
    testfile cpdir td1 td2
    glob td2/*
} {td2/td2}
test winFCmd-7.18 {TraverseWinTree: recurse on files: several files and dir} {

    cleanup
    file mkdir td1
    createfile td1/tf1
    createfile td1/tf2
    file mkdir td1/td2/td3
    createfile td1/tf3
    createfile td1/tf4
    testfile cpdir td1 td2
    lsort [glob td2/*]
} {td2/td2 td2/tf1 td2/tf2 td2/tf3 td2/tf4}
test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} {
    cleanup
    file mkdir td1
    testchmod 000 td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    list [file exists td2] [file writable td2]
} {1 0}
test winFCmd-7.20 {TraverseWinTree: call TraversalDelete: DOTREE_POSTD} {

    cleanup
    file mkdir td1
    createfile td1/tf1 tf1
    testfile rmdir -force td1
    file exists td1
} {0}
test winFCmd-7.21 {TraverseWinTree: fill errorPtr} {
    cleanup
    list [catch {testfile cpdir td1 td2} msg] $msg
} {1 {td1 ENOENT}}

test winFCmd-8.1 {TraversalCopy: DOTREE_F} {
    cleanup
    file mkdir td1
    list [catch {testfile cpdir td1 td1} msg] $msg
} {1 {td1 EEXIST}}
test winFCmd-8.2 {TraversalCopy: DOTREE_PRED} {
    cleanup
    file mkdir td1/td2
    testchmod 000 td1
    testfile cpdir td1 td2
    list [file writable td1] [file writable td1/td2]
} {0 1}
test winFCmd-8.3 {TraversalCopy: DOTREE_POSTD} {
    cleanup
    file mkdir td1
    testfile cpdir td1 td2
} {}

test winFCmd-9.1 {TraversalDelete: DOTREE_F} {
    cleanup
    file mkdir td1
    createfile td1/tf1
    testfile rmdir -force td1
} {}
test winFCmd-9.2 {TraversalDelete: DOTREE_F} {95} {
    cleanup
    file mkdir td1
    set fd [open td1/tf1 w]
    set msg [list [catch {testfile rmdir -force td1} msg] $msg]
    close $fd
    set msg
} {1 {td1\tf1 EACCES}}
test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} {
    cleanup
    file mkdir td1/td2
    testchmod 000 td1
    testfile rmdir -force td1
    file exists td1
} {0}
test winFCmd-9.4 {TraversalDelete: DOTREE_POSTD} {
    cleanup
    file mkdir td1/td1/td3/td4/td5
    testfile rmdir -force td1
} {}

test winFCmd-10.1 {AttributesPosixError - get} {
    cleanup
    list [catch {file attributes td1 -archive} msg] $msg
} {1 {could not read "td1": no such file or directory}}
test winFCmd-10.2 {AttributesPosixError - set} {
    cleanup
    list [catch {file attributes td1 -archive 0} msg] $msg
} {1 {could not read "td1": no such file or directory}}

test winFCmd-11.1 {GetWinFileAttributes} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -archive} msg] $msg [cleanup]
} {0 1 {}}
test winFCmd-11.2 {GetWinFileAttributes} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -readonly} msg] $msg [cleanup]
} {0 0 {}}
test winFCmd-11.3 {GetWinFileAttributes} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -hidden} msg] $msg [cleanup]
} {0 0 {}}
test winFCmd-11.4 {GetWinFileAttributes} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -system} msg] $msg [cleanup]
} {0 0 {}}
test winfcmd-11.5 {GetWinFileAttributes} {
    # attr of relative paths that resolve to root was failing
    # don't care about answer, just that test runs.

    set old [pwd]
    cd c:/
    file attr c:	    
    file attr c:.
    file attr . 
    cd $old
} {}

test winFCmd-12.1 {ConvertFileNameFormat} {
    cleanup
    close [open td1 w]
    list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
test winFCmd-12.2 {ConvertFileNameFormat} {
    cleanup
    file mkdir td1
    close [open td1/td1 w]
    list [catch {string tolower [file attributes td1/td1 -longname]} msg] $msg [cleanup]
} {0 td1/td1 {}}
test winFCmd-12.3 {ConvertFileNameFormat} {
    cleanup
    file mkdir td1
    file mkdir td1/td2
    close [open td1/td3 w]
    list [catch {string tolower [file attributes td1/td2/../td3 -longname]} msg] $msg [cleanup]
} {0 td1/td2/../td3 {}}
test winFCmd-12.4 {ConvertFileNameFormat} {
    cleanup
    close [open td1 w]
    list [catch {string tolower [file attributes ./td1 -longname]} msg] $msg [cleanup]
} {0 ./td1 {}}
test winFCmd-12.5 {ConvertFileNameFormat: absolute path} {
    list [file attributes / -longname] [file attributes \\ -longname]
} {/ /}
test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} {
    catch {file delete -force -- c:/td1}
    close [open c:/td1 w]
    list [catch {string tolower [file attributes c:/td1 -longname]} msg] $msg [file delete -force -- c:/td1]
} {0 c:/td1 {}}
test winFCmd-12.7 {ConvertFileNameFormat} {nonPortable} {
    string tolower [file attributes //bisque/tcl/ws -longname]
} {//bisque/tcl/ws}
test winFCmd-12.8 {ConvertFileNameFormat} {longFileNames} {
    cleanup
    close [open td1 w]
    list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
test winFCmd-12.9 {ConvertFileNameFormat} {win32s} {
    cleanup
    close [open td1 w]
    list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}
test winFCmd-12.10 {ConvertFileNameFormat} {longFileNames} {
    cleanup
    close [open td1td1td1 w]
    list [catch {file attributes td1td1td1 -shortname}] [cleanup]
} {0 {}}
test winFCmd-12.11 {ConvertFileNameFormat} {longFileNames} {
    cleanup
    close [open td1 w]
    list [catch {string tolower [file attributes td1 -shortname]} msg] $msg [cleanup]
} {0 td1 {}}

test winFCmd-13.1 {GetWinFileLongName} {
    cleanup
    close [open td1 w]
    list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]
} {0 td1 {}}

test winFCmd-14.1 {GetWinFileShortName} {
    cleanup
    close [open td1 w]
    list [catch {string tolower [file attributes td1 -shortname]} msg] $msg [cleanup]
} {0 td1 {}}

test winFCmd-15.1 {SetWinFileAttributes} {
    cleanup
    list [catch {file attributes td1 -archive 0} msg] $msg
} {1 {could not read "td1": no such file or directory}}
test winFCmd-15.2 {SetWinFileAttributes - archive} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -archive 1} msg] $msg [file attributes td1 -archive] [cleanup]
} {0 {} 1 {}}
test winFCmd-15.3 {SetWinFileAttributes - archive} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -archive 0} msg] $msg [file attributes td1 -archive] [cleanup]
} {0 {} 0 {}}
test winFCmd-15.4 {SetWinFileAttributes - hidden} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -hidden 1} msg] $msg [file attributes td1 -hidden] [file attributes td1 -hidden 0] [cleanup]
} {0 {} 1 {} {}}
test winFCmd-15.5 {SetWinFileAttributes - hidden} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -hidden 0} msg] $msg [file attributes td1 -hidden] [cleanup]
} {0 {} 0 {}}
test winFCmd-15.6 {SetWinFileAttributes - readonly} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -readonly 1} msg] $msg [file attributes td1 -readonly] [cleanup]
} {0 {} 1 {}}
test winFCmd-15.7 {SetWinFileAttributes - readonly} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -readonly 0} msg] $msg [file attributes td1 -readonly] [cleanup]
} {0 {} 0 {}}
test winFCmd-15.8 {SetWinFileAttributes - system} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -system 1} msg] $msg [file attributes td1 -system] [cleanup]
} {0 {} 1 {}}
test winFCmd-15.9 {SetWinFileAttributes - system} {
    cleanup
    close [open td1 w]
    list [catch {file attributes td1 -system 0} msg] $msg [file attributes td1 -system] [cleanup]
} {0 {} 0 {}}
test winFCmd-15.10 {SetWinFileAttributes - failing} {cdrom} {
    cleanup
    catch {file attributes $cdfile -archive 1}
} {1}

cleanup

return


foreach source {tef ted tnf tnd "" nul com1} {
    foreach chmodsrc {000 755} {
        foreach dest "tfn tfe tdn tdempty tdfull td1/td2 $p $p/td1 {} nul" {
	    foreach chmoddst {000 755} {
		puts hi
		cleanup
		file delete -force ted tef
		file mkdir ted
		createfile tef
		createfile tfe
		file mkdir tdempty
		file mkdir tdfull/td1/td2

		catch {testchmod $chmodsrc $source}
		catch {testchmod $chmoddst $dest}

		if [catch {file rename $source $dest} msg] {
		    puts "file rename $source ($chmodsrc) $dest ($chmoddst)"
		    puts $msg





		}




	    }
	}
    }
}

# cleanup
::test::cleanupTests
return












|


<
<
<
<
<
|







 







|
|







 







|
<
<
<
|







|






|


|







 







|


|





|
<
<
<



|




|





|



|



|




|





|






|






|







|













|





|



|



|



|


<




|



|




|




|
<
<
<



|




|



|






|






|





|





|





|






|
>







|




|




|





|




|



|




|





|



|



|




|







 







|





|






|






|





|




|




|





|







 







|


|




|



|



|






|



|





|




|






|






|








|


|


|




|



|





|






|






|




|



|



|



|




|





|




|






|







|




|






|




|




|




|






|





|





|



|






|






|






|






|





|
>


|







|






|






|









|




|






|
>










|







|
>






|




|




|






|





|













|






|





|



|




|




|




|




|




|











|




|





|






|




|


|




|


|




<
<
<
<
<
|




|





|





|





|



|




|




|




|




|




|




|




|




|




|
<
<
<
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
|
>
>
>
>
|
|
|
|

<
<
<

>
>
>
>
>
6
7
8
9
10
11
12
13
14
15





16
17
18
19
20
21
22
23
..
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
..
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
...
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
...
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
...
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
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
#
# 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.
#
# RCS: @(#) $Id: winFCmd.test,v 1.1.2.5 1999/03/23 20:07:05 hershey Exp $
#






if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc createfile {file {string a}} {
    set f [open $file w]
    puts -nonewline $f $string
    close $f
................................................................................
	}
	if {$x != ""} {
	    catch {eval file delete -force -- $x}
	}
    }
}

set ::tcltest::testConfig(cdrom) 0
set ::tcltest::testConfig(exdev) 0

# find a CD-ROM so we can test read-only filesystems.

set cdrom {}
set nodrive x:
foreach p {d e f g h i j k l m n o p q r s t u v w x y z} {
    set name ${p}:/dummy~~.fil
................................................................................
	        return $f
	    }
	}
    }
    return ""
}

if {$cdrom != ""} {



    set ::tcltest::testConfig(cdrom) 1
    set cdfile [findfile $cdrom]
}

if {[file exists c:/] && [file exists d:/]} {
    catch {file delete d:/tf1}
    if {[catch {close [open d:/tf1 w]}] == 0} {
	file delete d:/tf1
	set ::tcltest::testConfig(exdev) 1
    }
}

file delete -force -- td1
set foo [catch {open td1 w} testfile]
if {$foo} {
    set ::tcltest::testConfig(longFileNames) 0
} else {
    close $testfile
    set ::tcltest::testConfig(longFileNames) 1
    file delete -force -- td1
}

# A really long file name
# length of longname is 1216 chars, which should be greater than any static
# buffer or allowable filename.

................................................................................
append longname $longname

# Uses the "testfile" command instead of the "file" command.  The "file"
# command provides several layers of sanity checks on the arguments and
# it can be difficult to actually forward "insane" arguments to the
# low-level posix emulation layer.

test winFCmd-1.1 {TclpRenameFile: errno: EACCES} {pcOnly cdrom} {
    list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} {pcOnly} {
    cleanup
    file mkdir td1/td2/td3
    file mkdir td2
    list [catch {testfile mv td2 td1/td2} msg] $msg
} {1 EEXIST} 
test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} {pcOnly} {



    cleanup
    list [catch {testfile mv / td1} msg] $msg
} {1 EINVAL}
test winFCmd-1.4 {TclpRenameFile: errno: EINVAL} {pcOnly} {
    cleanup
    file mkdir td1
    list [catch {testfile mv td1 td1/td2} msg] $msg
} {1 EINVAL}
test winFCmd-1.5 {TclpRenameFile: errno: EISDIR} {pcOnly} {
    cleanup
    file mkdir td1
    createfile tf1
    list [catch {testfile mv tf1 td1} msg] $msg
} {1 EISDIR}
test winFCmd-1.6 {TclpRenameFile: errno: ENOENT} {pcOnly} {
    cleanup
    list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT}
test winFCmd-1.7 {TclpRenameFile: errno: ENOENT} {pcOnly} {
    cleanup
    list [catch {testfile mv "" tf2} msg] $msg
} {1 ENOENT}
test winFCmd-1.8 {TclpRenameFile: errno: ENOENT} {pcOnly} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 ""} msg] $msg
} {1 ENOENT}
test winFCmd-1.9 {TclpRenameFile: errno: ENOTDIR} {pcOnly} {
    cleanup
    file mkdir td1
    createfile tf1
    list [catch {testfile mv td1 tf1} msg] $msg
} {1 ENOTDIR}
test winFCmd-1.10 {TclpRenameFile: errno: EXDEV} {pcOnly exdev} {
    file delete -force d:/tf1
    file mkdir c:/tf1
    set msg [list [catch {testfile mv c:/tf1 d:/tf1} msg] $msg]
    file delete -force c:/tf1
    set msg
} {1 EXDEV}
test winFCmd-1.11 {TclpRenameFile: errno: EACCES} {pcOnly} {
    cleanup
    set fd [open tf1 w]
    set msg [list [catch {testfile mv tf1 tf2} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
test winFCmd-1.12 {TclpRenameFile: errno: EACCES} {pcOnly} {
    cleanup
    createfile tf1
    set fd [open tf2 w]
    set msg [list [catch {testfile mv tf1 tf2} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
test winFCmd-1.13 {TclpRenameFile: errno: EACCES} {pcOnly} {
    cleanup
    list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.14 {TclpRenameFile: errno: EACCES} {95} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 nul} msg] $msg
} {1 EACCES}
test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {nt} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 nul} msg] $msg
} {1 EEXIST}
test winFCmd-1.16 {TclpRenameFile: MoveFile() != FALSE} {pcOnly} {
    cleanup
    createfile tf1 tf1
    testfile mv tf1 tf2
    list [file exists tf1] [contents tf2]
} {0 tf1}
test winFCmd-1.17 {TclpRenameFile: MoveFile() == FALSE} {pcOnly} {
    cleanup
    list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT} 
test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} {pcOnly} {
    cleanup
    list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT} 
test winFCmd-1.19 {TclpRenameFile: errno == EACCES} {pcOnly} {
    cleanup
    list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.20 {TclpRenameFile: src is dir} {nt} {
    # under 95, this would actually succeed and move the current dir out from 
    # under the current process!

    cleanup
    file delete /tf1
    list [catch {testfile mv [pwd] /tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.21 {TclpRenameFile: long src} {pcOnly} {
    cleanup
    list [catch {testfile mv $longname tf1} msg] $msg
} {1 ENAMETOOLONG}
test winFCmd-1.22 {TclpRenameFile: long dst} {pcOnly} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 $longname} msg] $msg
} {1 ENAMETOOLONG}
test winFCmd-1.23 {TclpRenameFile: move dir into self} {pcOnly} {
    cleanup
    file mkdir td1
    list [catch {testfile mv [pwd]/td1 td1/td2} msg] $msg
} {1 EINVAL}
test winFCmd-1.24 {TclpRenameFile: move a root dir} {pcOnly} {



    cleanup
    list [catch {testfile mv / c:/} msg] $msg
} {1 EINVAL}
test winFCmd-1.25 {TclpRenameFile: cross file systems} {pcOnly cdrom} {
    cleanup
    file mkdir td1
    list [catch {testfile mv td1 $cdrom/td1} msg] $msg
} {1 EXDEV} 
test winFCmd-1.26 {TclpRenameFile: readonly fs} {pcOnly cdrom} {
    cleanup
    list [catch {testfile mv $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
test winFCmd-1.27 {TclpRenameFile: open file} {pcOnly} {
    cleanup
    set fd [open tf1 w]
    set msg [list [catch {testfile mv tf1 tf2} msg] $msg]
    close $fd
    set msg
} {1 EACCES}    
test winFCmd-1.28 {TclpRenameFile: errno == EEXIST} {pcOnly} {
    cleanup
    createfile tf1
    createfile tf2
    testfile mv tf1 tf2
    list [file exist tf1] [file exist tf2]
} {0 1}
test winFCmd-1.29 {TclpRenameFile: src is dir} {pcOnly} {
    cleanup
    file mkdir td1
    createfile tf1
    list [catch {testfile mv td1 tf1} msg] $msg
} {1 ENOTDIR} 
test winFCmd-1.30 {TclpRenameFile: dst is dir} {pcOnly} {
    cleanup
    file mkdir td1
    file mkdir td2/td2
    list [catch {testfile mv td1 td2} msg] $msg
} {1 EEXIST}
test winFCmd-1.31 {TclpRenameFile: TclpRemoveDirectory fails} {pcOnly} {
    cleanup
    file mkdir td1
    file mkdir td2/td2
    list [catch {testfile mv td1 td2} msg] $msg
} {1 EEXIST}
test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory succeeds} {pcOnly} {
    cleanup
    file mkdir td1/td2
    file mkdir td2
    testfile mv td1 td2
    list [file exist td1] [file exist td2] [file exist td2/td2]
} {0 1 1}
test winFCmd-1.33 {TclpRenameFile: After removing dst dir, MoveFile fails} \
	{pcOnly exdev} {
    file mkdir d:/td1
    testchmod 000 d:/td1
    set msg [list [catch {testfile mv c:/windows d:/td1} msg] $msg]
    set msg "$msg [file writable d:/td1]"
    file delete d:/td1
    set msg
} {1 EXDEV 0}
test winFCmd-1.34 {TclpRenameFile: src is dir, dst is not} {pcOnly} {
    file mkdir td1
    createfile tf1
    list [catch {testfile mv td1 tf1} msg] $msg
} {1 ENOTDIR}
test winFCmd-1.35 {TclpRenameFile: src is not dir, dst is} {pcOnly} {
    file mkdir td1
    createfile tf1
    list [catch {testfile mv tf1 td1} msg] $msg
} {1 EISDIR}
test winFCmd-1.36 {TclpRenameFile: src and dst not dir} {pcOnly} {
    createfile tf1 tf1
    createfile tf2 tf2
    testfile mv tf1 tf2
    contents tf2
} {tf1}
test winFCmd-1.37 {TclpRenameFile: need to restore temp file} {pcOnly} {
    # Can't figure out how to cause this. 
    # Need a file that can't be copied.
} {}

test winFCmd-2.1 {TclpCopyFile: errno: EACCES} {pcOnly cdrom} {
    cleanup
    list [catch {testfile cp $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
test winFCmd-2.2 {TclpCopyFile: errno: EISDIR} {pcOnly} {
    cleanup
    file mkdir td1
    list [catch {testfile cp td1 tf1} msg] $msg
} {1 EISDIR}
test winFCmd-2.3 {TclpCopyFile: errno: EISDIR} {pcOnly} {
    cleanup
    createfile tf1
    file mkdir td1
    list [catch {testfile cp tf1 td1} msg] $msg
} {1 EISDIR}
test winFCmd-2.4 {TclpCopyFile: errno: ENOENT} {pcOnly} {
    cleanup
    list [catch {testfile cp tf1 tf2} msg] $msg
} {1 ENOENT}
test winFCmd-2.5 {TclpCopyFile: errno: ENOENT} {pcOnly} {
    cleanup
    list [catch {testfile cp "" tf2} msg] $msg
} {1 ENOENT}
test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} {pcOnly} {
    cleanup
    createfile tf1
    list [catch {testfile cp tf1 ""} msg] $msg
} {1 ENOENT}
test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {95} {
    cleanup
    createfile tf1
    set fd [open tf2 w]
    set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
................................................................................
    cleanup
    list [catch {testfile cp nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} {95} {
    cleanup
    list [catch {testfile cp nul tf1} msg] $msg
} {1 ENOENT}
test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} {pcOnly} {
    cleanup
    createfile tf1 tf1
    testfile cp tf1 tf2
    list [contents tf1] [contents tf2]
} {tf1 tf1}
test winFCmd-2.11 {TclpCopyFile: CopyFile succeeds} {pcOnly} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    testfile cp tf1 tf2
    list [contents tf1] [contents tf2]
} {tf1 tf1}
test winFCmd-2.12 {TclpCopyFile: CopyFile succeeds} {pcOnly} {
    cleanup
    createfile tf1 tf1
    testchmod 000 tf1
    testfile cp tf1 tf2
    list [contents tf2] [file writable tf2]
} {tf1 0}
test winFCmd-2.13 {TclpCopyFile: CopyFile fails} {pcOnly} {
    cleanup
    createfile tf1
    file mkdir td1
    list [catch {testfile cp tf1 td1} msg] $msg
} {1 EISDIR} 
test winFCmd-2.14 {TclpCopyFile: errno == EACCES} {pcOnly} {
    cleanup
    file mkdir td1
    list [catch {testfile cp td1 tf1} msg] $msg
} {1 EISDIR}
test winFCmd-2.15 {TclpCopyFile: src is directory} {pcOnly} {
    cleanup
    file mkdir td1
    list [catch {testfile cp td1 tf1} msg] $msg
} {1 EISDIR}
test winFCmd-2.16 {TclpCopyFile: dst is directory} {pcOnly} {
    cleanup
    createfile tf1
    file mkdir td1
    list [catch {testfile cp tf1 td1} msg] $msg
} {1 EISDIR}
test winFCmd-2.17 {TclpCopyFile: dst is readonly} {pcOnly} {
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    testchmod 000 tf2
    testfile cp tf1 tf2
    list [file writable tf2] [contents tf2]
} {1 tf1}
................................................................................
    testchmod 000 tf2
    set fd [open tf2]
    set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
    close $fd
    set msg "$msg [file writable tf2]"
} {1 EACCES 0}    

test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} {pcOnly cdrom} {
    list [catch {testfile rm $cdfile $cdrom/dummy~~.fil} msg] $msg
} {1 EACCES}
test winFCmd-3.2 {TclpDeleteFile: errno: EISDIR} {pcOnly} {
    cleanup
    file mkdir td1
    list [catch {testfile rm td1} msg] $msg
} {1 EISDIR} 
test winFCmd-3.3 {TclpDeleteFile: errno: ENOENT} {pcOnly} {
    cleanup
    list [catch {testfile rm tf1} msg] $msg
} {1 ENOENT}
test winFCmd-3.4 {TclpDeleteFile: errno: ENOENT} {pcOnly} {
    cleanup
    list [catch {testfile rm ""} msg] $msg
} {1 ENOENT}
test winFCmd-3.5 {TclpDeleteFile: errno: EACCES} {pcOnly} {
    cleanup
    set fd [open tf1 w]
    set msg [list [catch {testfile rm tf1} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
test winFCmd-3.6 {TclpDeleteFile: errno: EACCES} {