Tcl Source Code

Check-in [83929e34ec]
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:lint: changed a tcltest namespace variable name from tmpDir to workingDir. changes: made more tests atomic. README is now updated to match new test suite features.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-1-branch-old
Files: files | file ages | folders
SHA1: 83929e34eca8b2b2ff04910fc95880727e0b2bfd
User & Date: hershey 1999-03-24 02:48:54
Context
1999-03-24
04:22
* tools/tcl.wse: Fixed file association to look in the right place for the wish icon. [Bug: 1544] check-in: d123a468a4 user: stanton tags: core-8-1-branch-old
02:48
lint: changed a tcltest namespace variable name from tmpDir to workingDir. changes: made mo... check-in: 83929e34ec user: hershey tags: core-8-1-branch-old
02:38
Fixed serial port check-in: 762e3896db user: redman 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
..
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
...
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.
................................................................................
	-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"

See the defs.tcl file for information about each of these constraints.
Other constraints can be added at any time.  See the "Writing a new
test" section below for more details about using built-in constraints
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.


Writing a new test:
-------------------



The following is the spec for the "test" command:

	test <name> <description> ?<constraint>? <script> <answer>

The <name> field should be:


	<target>-<majorNum>.<minorNum>

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.

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



|

>
>

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







 







|
>
>
>
>
>
>


<
>
|
|





<
<

<
|
|

|



|


|
<
<

<
<
>

<
<
<
<
<
<
<
<
>
>

>
>

<
<
>

<
<
<
>
>

<
<
<
<
<
<
<
<
<
<
<
>

<
<
<
>

<
>

>
>
>

<
<
>

<
<
<
>

<
>

<
<
<
<
>

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>


<
<
<
<
<

<
|
|

>
>
|

|

<
<
>
|
<
|
|
<
|

<
<
<
<
<
<
>
>

>
>
>
|
|
|








>
>
>
>
>
>
>
>

>
>
>
>
>
|
|

|
|
>
|







 







<
>
>
|

<
|
<
>
|
|
<
|

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


|







|
|








|
|
|
<
>
>
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
..
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
...
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
README -- Tcl test suite design document.

RCS: @(#) $Id: README,v 1.1.2.4 1999/03/24 02:48:54 hershey Exp $

Contents:
---------

    1. Introduction
    2. Definitions file
    3. Writing a new test
    4. Constraints
    5. Adding a New Test File
    6. Test output
    7. Selecting tests for execution within a file
    8. Selecting files to be sourced by all.tcl
    9. Incompatibilities with prior Tcl versions

1. 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.
................................................................................
	-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".  To use the options in
	interactive mode, you can set their corresponding tcltest
	namespace variables:
		  ::tcltest::matchingTests
		  ::tcltest::skippingTests
		  ::tcltest::testConfig(nonPortable)
		  ::tcltest::testConfig(knownBug)

In all cases, no output will be generated if all goes well, except for

a listing of the test files and a statical summary.  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.





2. Definitions file:
--------------------

The file "defs.tcl" defines the "tcltest" 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 "tcltest"
namespace and automatically imported:

    test	      Run a test script.





    cleanupTests      Print stats and remove files created by tests.









    dotests	      Source a test file and run tests of the
		      specified pattern.

    makeFile	      Create a file--the file will automatically
		      be removed by cleanupTests.



    removeFile	      Force a file to be removed.




    makeDirectory     Create a directory--the directory will
		      automatically be removed by cleanupTests.












    removeDirectory   Force a directory to be removed.




    viewFile	      Returns the contents of a file.


    normalizeMsg      Remove extra newlines from a string.

    bytestring	      Construct a string that consists of the
		      requested sequence of bytes, as opposed to a
		      string of properly formed UTF-8 characters.



    set_iso8859_1_locale    Set the locale to iso8859_1.




    restore_locale    Restore the locale to its original setting.


    saveState	      Save the procedure and global variable names.





    restoreState      Restore the procedure and global variable names.




























































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








3. Writing a new test:
----------------------

The test procedure runs a test script and prints an error message if
the script's result does not match the expected result.  The following
is the spec for the "test" command:

    test <name> <description> ?<constraint>? <script> <expectedAnswer>



The <name> argument should follow the pattern,
"<target>-<majorNum>.<minorNum>".  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.







The <description> argument is a short textual description of the test,
to help humans understand what it does.

The optional <constraints> argument is 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 false or does
not exist, the test is skipped.  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.

The <script> argument contains the script to run to carry out the
test.  It must return a result that can be checked for correctness.
If your script 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.

The <expectedAnswer> argument will be compared against the result of
evaluating the <script> argument.  If they match, the test passes,
otherwise the test fails.


4. Constraints:
---------------

Constraints are used to determine whether a test should be skipped.
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.

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



5. Adding a new test file:
--------------------------


Tests files should begin by sourcing the defs.tcl file:


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

    }

Test files sould end by cleaning up after themselves and calling
::tcltest::cleanupTests.  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.

    # Remove files created by these tests
    # Change to original working directory
    # Unset global arrays
    ::tcltest::cleanupTests
    return

The all.tcl file will source your new test file as if the filename
matches the tests/*.test pattern (as it should).  Test files that
contain regression (or glass-box) tests should be named according to
the Tcl or C code file that they are testing.  For example, the test
file for the C file tclCmdAH.c is cmdAH.test.  Test files that contain
black-box tests may not correspond to any Tcl or C code file so they
should match the pattern "*_bb.test".

Be sure your new test file can be run from any working directory.

Be sure no temporary files are left behind by your test file.

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


6. Test output:
---------------

After all specified test files are sourced, 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


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

See the defs.tcl file for information about each of these constraints.
Other constraints can be added at any time.  See the "Writing a new
test" section below for more details about using built-in constraints
and adding new ones.


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


9. Incompatibilities with prior Tcl versions:
---------------------------------------------

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

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

   The introduction of the "tcltest" namespace is a precursor to using
   a "tcltest" 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 with eachother
   or with existing files.  All tests must now run independently of
   their working directory.



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

................................................................................
    }
}

# cleanup
puts stdout "\nTests ended at [eval $timeCmd]"
::tcltest::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
..
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
# 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.5 1999/03/24 02:48:54 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::workingDir"
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"
}

................................................................................
    }
}

# 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
...
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 i x result y}
catch {rename foo ""}
catch {rename check ""}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
# 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.5 1999/03/24 02:48:55 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 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
..
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
}

................................................................................
test assocd-3.3 {testing deleting assoc data} {
   list [catch {testdelassocdata nonexistent} msg] $msg
} {0 {}}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
# 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.5 1999/03/24 02:48:55 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
}

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

................................................................................
    list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
} {3 del2 {0 0 0 del1 del2}}

# cleanup
testasync delete
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
# 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.5 1999/03/24 02:48:56 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
}

................................................................................
    list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
} {3 del2 {0 0 0 del1 del2}}

# cleanup
testasync delete
::tcltest::cleanupTests
return












Changes to tests/autoMkindex.tcl.

46
47
48
49
50
51
52

53
54
55
56
57
58
59
60
61
62
    }
    namespace eval ::buried {
        proc relative {args} {return "relative: $args"}
        proc ::top {args} {return "top: $args"}
        proc ::buried::explicit {args} {return "explicit: $args"}
    }
}

















>










46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
    }
    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
..
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
................................................................................

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


















|







|







 







>











5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
..
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
#
# 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.5 1999/03/24 02:48:57 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::workingDir 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
................................................................................

# 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
...
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 {rename p ""}
catch {rename q ""}
catch {rename cmd ""}
catch {rename value:at: ""}
catch {unset x}
::tcltest::cleanupTests
return


















|







 







>











11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
#
# 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.5 1999/03/24 02:48:57 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 {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
....
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
................................................................................
    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


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
#
# 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.5 1999/03/24 02:48:57 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
................................................................................
    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
..
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}
................................................................................
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


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
# 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.5 1999/03/24 02:48:58 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}
................................................................................
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
...
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
................................................................................
    set time [clock scan "March 1, 2001" -gmt true]
    clock format $time -format %j -gmt true
} {060}

# cleanup
::tcltest::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
#
# 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.5 1999/03/24 02:48:58 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
................................................................................
    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
....
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]
................................................................................
file delete gorp.file
file delete link.file

cd $cmdAHwd

::tcltest::cleanupTests
return



















|







 







>












6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
#
# 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.9 1999/03/24 02:48:59 hershey Exp $

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

global env
set cmdAHwd [pwd]
................................................................................
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
...
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
................................................................................
    }
    set viewlist
} [list "abc" "abc\\200"]

# cleanup
::tcltest::cleanupTests
return


















|







 







>











4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
#
# 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.6 1999/03/24 02:48:59 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
................................................................................
    }
    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
..
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
}

................................................................................
} {testCmd ::cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2 ::newTestCmd2}

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


















|







 







>











9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
# 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.5 1999/03/24 02:49:00 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
}

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

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



















|







 







>












7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
# 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.5 1999/03/24 02:49:00 hershey Exp $

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

# Tcl_PwdObjCmd

................................................................................
# 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
...
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
................................................................................
    p
} 3

# cleanup
unset a
::tcltest::cleanupTests
return


















|







 







>











8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
#
# 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.4 1999/03/24 02:49:01 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
................................................................................
    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
...
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
................................................................................
} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012"}}

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


















|







 







>











4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
#
# 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.4 1999/03/24 02:49:01 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
................................................................................
} {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
...
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 ""}
catch {namespace delete test_ns_compile}
catch {unset x}
catch {unset y}
catch {unset a}
::tcltest::cleanupTests
return



















|







 







>












6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
#
# 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.6 1999/03/24 02:49:02 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 ""}
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
..
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
................................................................................
test concat-4.3 {pruning off extra white space sets length correctly} {
    llength [concat { {{a}} }]
} 1

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
# 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.5 1999/03/24 02:49:02 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
................................................................................
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
..
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
}

................................................................................
test dcall-1.6 {deletion callbacks} {
    lsort -increasing [testdcall 20 21 22 -21 -22 -20]
} {}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
# 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.5 1999/03/24 02:49:03 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
}

................................................................................
test dcall-1.6 {deletion callbacks} {
    lsort -increasing [testdcall 20 21 22 -21 -22 -20]
} {}

# cleanup
::tcltest::cleanupTests
return












Changes to tests/defs.tcl.

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
..
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
...
123
124
125
126
127
128
129

130

131

132
133
134
135
136
137
138
139
...
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
...
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
...
474
475
476
477
478
479
480
481


482
483
484
485
486
487
488
489
490
...
581
582
583
584
585
586
587
588

589
590
591
592
593
594
595
...
654
655
656
657
658
659
660















661
662
663
664
665
666
667
...
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
...
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
...
906
907
908
909
910
911
912






913
914
915
916
917
918
919
920
921
922

923
924
925
926
927
928
929
...
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
#	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
    }

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

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

    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)}]
................................................................................
	}
    }
}

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

    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)
    }
................................................................................
	    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
	    }
................................................................................
	    # 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)]
................................................................................
    } 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::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
................................................................................
	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."
    }

................................................................................
    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
................................................................................
	destroy .focus
    }
}

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
















|










|



|
<







 







|
|
|
|







 







>
|
>
|
>
|







 







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


|







 







|


|


>
|




|
<
|
<
<
<
|
<
|







 







|
>
>

|







 







|
>







 







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







 







>
|

|
|
<
>










>



>
|







>
>

>
|







 







|







 







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







 








<
<
<
<
<
<
<
<
<
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
..
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
...
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
...
303
304
305
306
307
308
309








































310
311
312
313
314
315
316
317
318
319
...
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
...
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
...
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
...
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
...
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
...
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
...
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
...
962
963
964
965
966
967
968
969









#	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.4 1999/03/24 02:49:03 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 "tcltest" namespace for all testing variables and procedures
namespace eval tcltest {
    set procList [list test cleanupTests dotests saveState restoreState \
	    normalizeMsg makeFile removeFile makeDirectory removeDirectory \
	    viewFile bytestring set_iso8859_1_locale restore_locale]

    if {[info exists tk_version]} {
	lappend procList setupbg dobg bgReady cleanupbg fixfocus
    }
    foreach proc $procList {
	namespace export $proc
    }

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

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

    # Tests should remove all files they create.  The test suite will
    # check the current working dir 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]
................................................................................

    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)}]
................................................................................
	}
    }
}

::tcltest::initConfig










































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

    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., -match == -m).
    # Note that -verbose cannot be abbreviated to -v in wish because it conflicts
    # with the wish option -visual.
    foreach arg {-verbose -match -skip -constraints} {
	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::workingDir to [pwd].

    # Save the names of files that already exist in ::tcltest::workingDir.



    set ::tcltest::workingDir [pwd]

    foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] {
	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)
    }
................................................................................
	    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::workingDir that were not
	# pre-existing.

	set currentFiles {}
	foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] {
	    lappend currentFiles [file tail $file]
	}
	set filesNew {}
	foreach file $currentFiles {
	    if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
		lappend filesNew $file
	    }
................................................................................
	    # 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)]
................................................................................
    } else { 
	incr ::tcltest::numTests(Passed)
	if {[string first p $::tcltest::verbose] != -1} {
	    puts stdout "++++ $name PASSED"
	}
    }
}

# ::tcltest::dotests --
#
#	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.
#
# Arguments:
#	file    name of tests file to source
#	args    pattern selecting the tests you want to execute
#
# Results:
#	none

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

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

# Locate tcltest executable

if {![info exists tk_version]} {
    set tcltest [info nameofexecutable]

    if {$tcltest == "{}"} {
	set tcltest {}

    }
}

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(platform) != "windows") || \
	    (![info exists tk_version])} {
	set f [open "|[list $tcltest tmp]" r]
	close $f
    }
    set ::tcltest::testConfig(stdio) 1
}
catch {file delete -force tmp}

# Deliberately call the socket with the wrong number of arguments.  The error
# message you get will indicate whether sockets are available on this system.
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
................................................................................
	wm geometry . +0+0
	update
    }

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

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

................................................................................
    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
	}
	
	# The following code segment cannot be run on Windows in Tk8.1b2
	# This bug is logged as a pipe bug (bugID 1495).

	global tcl_platform
	if {$tcl_platform(platform) != "windows"} {
	    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
................................................................................
	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
...
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
}

................................................................................
    lappend result [testdstring get]
} {{} {This is a specially-allocated stringz}}

# cleanup
testdstring free
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
# 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.5 1999/03/24 02:49:04 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
}

................................................................................
    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
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
..
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
...
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
...
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
...
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
...
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"
}
proc fromutf {args} {
    global x
    lappend x "fromutf $args"
}







# TclInitEncodingSubsystem is tested by the rest of this file
# TclFinalizeEncodingSubsystem is not currently tested

test encoding-1.1 {Tcl_GetEncoding: system encoding} {
    testencoding create foo toutf fromutf
    set old [encoding system]
    encoding system foo
    set x {}
    encoding convertto abcd
    encoding system $old
    testencoding delete foo
    set x
} {{fromutf }}
test encoding-1.2 {Tcl_GetEncoding: existing encoding} {
    testencoding create foo toutf fromutf
    set x {}
    encoding convertto foo abcd
    testencoding delete foo
    set x
} {{fromutf }}
test encoding-1.3 {Tcl_GetEncoding: load encoding} {
................................................................................
    list [encoding convertto jis0208 \u4e4e] \
	[encoding convertfrom jis0208 8C]
} "8C \u4e4e"

test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} {
    encoding convertto jis0208 \u4e4e
} {8C}
test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} {
    set system [encoding system]
    set path [testencoding path]
    encoding system jis0208		;# incr ref count
    testencoding path .
    set x [encoding convertto jis0208 \u4e4e]	;# old one found   
    encoding system identity
    lappend x [catch {encoding convertto jis0208 \u4e4e} msg] $msg
................................................................................
    set old [fconfigure stdout -encoding]
    fconfigure stdout -encoding jis0208
    set x [fconfigure stdout -encoding]
    fconfigure stdout -encoding $old
    set x
} {jis0208}

test encoding-4.1 {Tcl_GetEncodingNames} {pcOnly} {
    file mkdir tmp/encoding
    close [open tmp/encoding/junk.enc w]
    close [open tmp/encoding/junk2.enc w]
    cd tmp
    set path [testencoding path]
    testencoding path .
    set x [encoding names]
    testencoding path $path
    cd ..
    file delete -force tmp
    set x
} {junk utf-8 cp1252 junk2 identity unicode iso8859-1}
test encoding-4.1 {Tcl_GetEncodingNames} {unixOnly} {
    file mkdir tmp/encoding
    close [open tmp/encoding/junk.enc w]
    close [open tmp/encoding/junk2.enc w]
    cd tmp
    set path [testencoding path]
    testencoding path .
    set x [encoding names]
................................................................................
} {8C}
test encoding-5.2 {Tcl_SetSystemEncoding: test ref count} {
    set old [encoding system]
    encoding system $old
    string compare $old [encoding system]
} {0}

test encoding-6.1 {Tcl_CreateEncoding: new} {
    testencoding create foo {toutf 1} {fromutf 2}
    set x {}
    encoding convertfrom foo abcd
    encoding convertto foo abcd
    testencoding delete foo
    set x
} {{toutf 1} {fromutf 2}}
test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {
    testencoding create foo {toutf a} {fromutf b}
    set x {}
    encoding convertfrom foo abcd
    encoding convertto foo abcd
    testencoding delete foo
    set x
} {{toutf a} {fromutf b}}
................................................................................
    fconfigure $f -translation binary -encoding iso8859-1
    set x [read $f]
    close $f
    file delete dummy
    set x
} "ab\x8c\xc1g"

test encoding-11.1 {LoadEncodingFile: unknown encoding} {
    set system [encoding system]
    set path [testencoding path]
    encoding system iso8859-1
    testencoding path {}
    set x [list [catch {encoding convertto jis0208 \u4e4e} msg] $msg]
    testencoding path $path
    encoding system $system
................................................................................
} "\u4e4e"
test encoding-11.4 {LoadEncodingFile: multi-byte} {
    encoding convertfrom shiftjis \x8c\xc1
} "\u4e4e"
test encoding-11.5 {LoadEncodingFile: escape file} {
    encoding convertto iso2022 \u4e4e
} "\x1b(B\[email protected]"
test encoding-11.6 {LoadEncodingFile: invalid file} {
    set system [encoding system]
    set path [testencoding path]
    encoding system identity
    testencoding path tmp
    file mkdir tmp/encoding
    set f [open tmp/encoding/splat.enc w]
    fconfigure $f -translation binary 
................................................................................

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

# cleanup
::tcltest::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
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
..
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
...
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
...
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
...
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
...
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
#
# 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.6 1999/03/24 02:49:04 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"
}
proc fromutf {args} {
    global x
    lappend x "fromutf $args"
}

# Some tests require the testencoding command

set ::tcltest::testConfig(testencoding) \
	[expr {[info commands testencoding] != {}}]


# TclInitEncodingSubsystem is tested by the rest of this file
# TclFinalizeEncodingSubsystem is not currently tested

test encoding-1.1 {Tcl_GetEncoding: system encoding} {testencoding} {
    testencoding create foo toutf fromutf
    set old [encoding system]
    encoding system foo
    set x {}
    encoding convertto abcd
    encoding system $old
    testencoding delete foo
    set x
} {{fromutf }}
test encoding-1.2 {Tcl_GetEncoding: existing encoding} {testencoding} {
    testencoding create foo toutf fromutf
    set x {}
    encoding convertto foo abcd
    testencoding delete foo
    set x
} {{fromutf }}
test encoding-1.3 {Tcl_GetEncoding: load encoding} {
................................................................................
    list [encoding convertto jis0208 \u4e4e] \
	[encoding convertfrom jis0208 8C]
} "8C \u4e4e"

test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} {
    encoding convertto jis0208 \u4e4e
} {8C}
test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} {testencoding} {
    set system [encoding system]
    set path [testencoding path]
    encoding system jis0208		;# incr ref count
    testencoding path .
    set x [encoding convertto jis0208 \u4e4e]	;# old one found   
    encoding system identity
    lappend x [catch {encoding convertto jis0208 \u4e4e} msg] $msg
................................................................................
    set old [fconfigure stdout -encoding]
    fconfigure stdout -encoding jis0208
    set x [fconfigure stdout -encoding]
    fconfigure stdout -encoding $old
    set x
} {jis0208}

test encoding-4.1 {Tcl_GetEncodingNames} {pcOnly testencoding} {
    file mkdir tmp/encoding
    close [open tmp/encoding/junk.enc w]
    close [open tmp/encoding/junk2.enc w]
    cd tmp
    set path [testencoding path]
    testencoding path .
    set x [encoding names]
    testencoding path $path
    cd ..
    file delete -force tmp
    set x
} {junk utf-8 cp1252 junk2 identity unicode iso8859-1}
test encoding-4.1 {Tcl_GetEncodingNames} {unixOnly testencoding} {
    file mkdir tmp/encoding
    close [open tmp/encoding/junk.enc w]
    close [open tmp/encoding/junk2.enc w]
    cd tmp
    set path [testencoding path]
    testencoding path .
    set x [encoding names]
................................................................................
} {8C}
test encoding-5.2 {Tcl_SetSystemEncoding: test ref count} {
    set old [encoding system]
    encoding system $old
    string compare $old [encoding system]
} {0}

test encoding-6.1 {Tcl_CreateEncoding: new} {testencoding} {
    testencoding create foo {toutf 1} {fromutf 2}
    set x {}
    encoding convertfrom foo abcd
    encoding convertto foo abcd
    testencoding delete foo
    set x
} {{toutf 1} {fromutf 2}}
test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} {
    testencoding create foo {toutf a} {fromutf b}
    set x {}
    encoding convertfrom foo abcd
    encoding convertto foo abcd
    testencoding delete foo
    set x
} {{toutf a} {fromutf b}}
................................................................................
    fconfigure $f -translation binary -encoding iso8859-1
    set x [read $f]
    close $f
    file delete dummy
    set x
} "ab\x8c\xc1g"

test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} {
    set system [encoding system]
    set path [testencoding path]
    encoding system iso8859-1
    testencoding path {}
    set x [list [catch {encoding convertto jis0208 \u4e4e} msg] $msg]
    testencoding path $path
    encoding system $system
................................................................................
} "\u4e4e"
test encoding-11.4 {LoadEncodingFile: multi-byte} {
    encoding convertfrom shiftjis \x8c\xc1
} "\u4e4e"
test encoding-11.5 {LoadEncodingFile: escape file} {
    encoding convertto iso2022 \u4e4e
} "\x1b(B\[email protected]"
test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} {
    set system [encoding system]
    set path [testencoding path]
    encoding system identity
    testencoding path tmp
    file mkdir tmp/encoding
    set f [open tmp/encoding/splat.enc w]
    fconfigure $f -translation binary 
................................................................................

# 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
...
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
................................................................................
    set env($name) $env2($name)
}

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


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
# 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.6 1999/03/24 02:49:04 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
................................................................................
    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
...
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
................................................................................
    list $errorCode $errorInfo
} {NONE 1}

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


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
# 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.5 1999/03/24 02:49:05 hershey Exp $

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

proc foo {} {
    global errorInfo
................................................................................
    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
..
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}
................................................................................
	set a 1
	error \"test error\"
    }\""

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
# 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.5 1999/03/24 02:49:05 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}
................................................................................
	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
...
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} {
................................................................................

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


















|







 







>











5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
#
# 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.5 1999/03/24 02:49:06 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} {
................................................................................

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

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


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
# 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.5 1999/03/24 02:49:06 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.
................................................................................

# 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
...
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 {rename {} ""}
catch {rename { } ""}
catch {unset x}
catch {unset y}
catch {unset msg}
::tcltest::cleanupTests
return


















|







 







>











10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
#
# 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.5 1999/03/24 02:49:07 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 {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
...
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 "call Intel customer service immediately at 1-800-628-8686"
    puts "to request a replacement processor."
}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
# 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.5 1999/03/24 02:49:07 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 "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
...
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
................................................................................
    p
} 3

# cleanup
unset a
::tcltest::cleanupTests
return


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
#
# 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.5 1999/03/24 02:49:08 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
................................................................................
    p
} 3

# cleanup
unset a
::tcltest::cleanupTests
return












Changes to tests/fCmd.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
2143
2144
2145
2146
2147
2148
2149

2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
#
# 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} {
................................................................................
    list [catch {eval file attributes foo.tmp [lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp]
} {0 {} {}}

# cleanup
cleanup
::tcltest::cleanupTests
return


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
#
# 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.7 1999/03/24 02:49:08 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} {
................................................................................
    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.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
1400
1401
1402
1403
1404
1405
1406

1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
#
# 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\""
................................................................................
removeDirectory globTest
cd $temp
set env(HOME) $oldhome
testsetplatform $platform
catch {unset oldhome platform temp result}
::tcltest::cleanupTests
return


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
#
# 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.5 1999/03/24 02:49:09 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\""
................................................................................
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
..
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} {
................................................................................
    }
    set a
} {1 2 3}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
#
# 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.5 1999/03/24 02:49:09 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} {
................................................................................
    }
    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
...
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
................................................................................
    set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}]
    set a
} {}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
# 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.5 1999/03/24 02:49:10 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
................................................................................
    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
...
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.
................................................................................
} {wrong # args: should be "break"}

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


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
#
# 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.5 1999/03/24 02:49:11 hershey Exp $

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

catch {unset a}
catch {unset x}

# Basic "foreach" operation.
................................................................................
} {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
...
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


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
#
# 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.6 1999/03/24 02:49:11 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
..
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
................................................................................
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


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
#
# 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.5 1999/03/24 02:49:12 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
................................................................................
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
...
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
}

................................................................................
    catch {history gorp} msg
    set msg
} {bad option "gorp": must be add, change, clear, event, info, keep, nextid, or redo}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
# 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.5 1999/03/24 02:49:12 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
}

................................................................................
    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
...
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]} {
................................................................................
	testthread exit
    }
} else {
    close $listen
}
::tcltest::cleanupTests
return


















|







 







>











8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
# 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.6 1999/03/24 02:49:13 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]} {
................................................................................
	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
...
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]} {
................................................................................

# cleanup
unset url
unset port
close $listen
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
# 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.5 1999/03/24 02:49:13 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]} {
................................................................................

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


















|







 







>











9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
157
158
159
160
161
162
163
164
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-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.5 1999/03/24 02:49:14 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 {}
................................................................................
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
....
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.

................................................................................
test if-9.1 {if cmd with namespace qualifiers} {
    ::if {1} {set x 4}
} 4

# cleanup
::tcltest::cleanupTests
return


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
#
# 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.6 1999/03/24 02:49:14 hershey Exp $

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

# Basic "if" operation.

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

................................................................................
    set x {20 x}
    list [catch {incr x 1} msg] $msg
} {1 {expected integer but got "20 x"}}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
# 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.5 1999/03/24 02:49:15 hershey Exp $

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

catch {unset x}

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

................................................................................
    set x "  -  "
    list [catch {$z x 1} msg] $msg
} {1 {expected integer but got "  -  "}}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
#
# 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.5 1999/03/24 02:49:15 hershey Exp $

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

# Basic "incr" operation.

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

................................................................................
    lindex $x 1
    testindexobj 1 1 $x abc def {a b} zzz
} {2}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
#
# 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.5 1999/03/24 02:49:16 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 
}

................................................................................
    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
...
499
500
501
502
503
504
505

506
507
508
509
510
511
512
513
514
515
516
# 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.5 1999/03/24 01:40:27 surles 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.
................................................................................
    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


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
# 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.6 1999/03/24 02:49:16 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.
................................................................................
    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
...
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_*]}
................................................................................

}

# cleanup
interp delete $testInterp
::tcltest::cleanupTests
return


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
#
# 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.5 1999/03/24 02:49:17 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_*]}
................................................................................

}

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

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

# cleanup
foreach i [interp slaves] {
  interp delete $i
}
::tcltest::cleanupTests
return


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
#
# 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.8 1999/03/24 02:49:17 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:

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

# 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
....
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"
................................................................................
foreach file [list fooBar longfile script output test1 pipe my_script foo \
	bar test2 test3 cat stdout] {
    ::tcltest::removeFile $file
}
restoreState
::tcltest::cleanupTests
return



















|







 







>












8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
6787
6788
6789
6790
6791
6792
6793
6794
6795
6796
6797
6798
6799
6800
6801
6802
6803
6804
6805
6806
# 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.10 1999/03/24 02:49:18 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"
................................................................................
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
...
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
................................................................................
# delay long enough for background processes to finish
after 500
foreach file [list test5 pipe output] {
    ::tcltest::removeFile $file
}
::tcltest::cleanupTests
return


















|







 







>











8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
# 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.6 1999/03/24 02:49:19 hershey Exp $

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

removeFile test1
removeFile pipe
................................................................................
# 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
...
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)}
................................................................................
    list $err9 $err10 $err11
} {{"TestOpenFileChannelProc1": could not be deleteed} {"TestOpenFileChannelProc2": could not be deleteed} {"TestOpenFileChannelProc3": could not be deleteed}}
}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
# 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.6 1999/03/24 02:49:19 hershey Exp $
 
if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set unsetScript {
    catch {unset testStat1(size)}
................................................................................
    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
..
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
................................................................................
test join-3.2 {join is binary ok} {
  string length [join "a\0b a\0b a\0b"]
} 11

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
# 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.5 1999/03/24 02:49:20 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
................................................................................
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
..
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-3.4 {quoted elements} {
    lindex {a b {c d "e} {f g"}} 2
} {c d "e}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
# 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.5 1999/03/24 02:49:20 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-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
...
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
}

................................................................................
foreach i {int real bool string} {
    catch {unset $i}
}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
# 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.5 1999/03/24 02:49:21 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
}

................................................................................
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
...
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 ""}
................................................................................
} "7 a b c"

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


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
# 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.5 1999/03/24 02:49:22 hershey Exp $

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

catch {unset lis}
catch {rename p ""}
................................................................................
} "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
...
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-3.1 {SetListFromAny and lrange/concat results} {
    slowsort {fred julie alex carol bill annie}
} {alex annie bill carol fred julie}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
# 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.5 1999/03/24 02:49:22 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-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
...
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
}

................................................................................
test listobj-9.1 {UpdateStringOfList} {
    string length [list foo\x00help]
} 8

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
#
# 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.5 1999/03/24 02:49:23 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
}

................................................................................
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
..
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}
................................................................................
test llength-2.3 {error conditions} {
    list [catch {llength "a b c \{"} msg] $msg
} {1 {unmatched open brace in list}}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
36
37
38
39
40
41
42
43
44
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: llength.test,v 1.1.2.5 1999/03/24 02:49:23 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}
................................................................................
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
...
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.
................................................................................
    } "{{[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


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
#
# 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.6 1999/03/24 02:49:24 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.
................................................................................
    } "{{[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
..
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
................................................................................
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


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
# 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.5 1999/03/24 02:49:25 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
................................................................................
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
...
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
................................................................................
    p
} "a b c"

# cleanup
catch {unset foo}
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
# 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.5 1999/03/24 02:49:25 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
................................................................................
    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
..
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} {
................................................................................
    append x two
    lsearch -exact [list foo one\000two bar] $x
} 1

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
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 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 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.6 1999/03/24 02:49:26 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} {
................................................................................
    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
...
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}
................................................................................
    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


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
#
# 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.5 1999/03/24 02:49:26 hershey Exp $
#

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

catch {file delete -force 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
..
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 {} {
................................................................................
    (compiling body of proc "tstProc", line 4)
    invoked from within
"tstProc"}}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











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
# 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.5 1999/03/24 02:49:26 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 {} {
................................................................................
    (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
...
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]} {
................................................................................

# Clean out the msg catalogs
::msgcat::mclocale $oldlocale
file delete msgdir

::tcltest::cleanupTests
return


















|







 







>











8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
#
# 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.6 1999/03/24 02:49:27 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]} {
................................................................................

# 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
...
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_*]}
................................................................................
catch {unset test_ns_var_global}
catch {unset cmd}
eval namespace delete [namespace children :: test_ns_*]

# cleanup
::tcltest::cleanupTests
return


















|







 







>











10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
# 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.5 1999/03/24 02:49:27 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_*]}
................................................................................
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
....
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_*]}
................................................................................
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
eval namespace delete [namespace children :: test_ns_*]
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
....
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
#
# 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.5 1999/03/24 02:49:28 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_*]}
................................................................................
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
...
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
}

................................................................................
} {{} 1024 1024 int 4 4 0 boolean 3 2}

testobj freeallvars

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
#
# 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.5 1999/03/24 02:49:28 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
}

................................................................................
} {{} 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
...
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
................................................................................
    ::tcl::OptKeyDelete $key
    set args
} {a b c}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
# 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.5 1999/03/24 02:49:29 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
................................................................................
    ::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
..
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.3 {TclOSACompileCmd} {macOnly appleScript} {
    list [catch {AppleScript compile} msg] $msg
} {1 {wrong # args: should be "AppleScript compile ?options? code"}}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
#
# 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.5 1999/03/24 02:49:30 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.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
...
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 
}

................................................................................
    info complete "# Comment should be complete command"
} 1

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



















|







 







>












4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
#
# 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.10 1999/03/24 02:49:30 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 
}

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


















|







 







>











4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
#
# 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.4 1999/03/24 02:49:31 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] == {}} {
................................................................................
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
...
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
................................................................................
test parseOld-15.5 {TclScriptEnd procedure} {
    info complete "xyz \[abc"
} {0}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
# 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.4 1999/03/24 02:49:31 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
................................................................................
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
..
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
}
................................................................................
    list [catch {pid gorp} msg] $msg
} {1 {can not find channel named "gorp"}}

# cleanup
catch {::tcltest::removeFile test1}
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
# 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.5 1999/03/24 02:49:32 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
}
................................................................................
    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
...
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
................................................................................

}

# cleanup
interp delete $i
::tcltest::cleanupTests
return


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
#
# 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.7 1999/03/24 02:49:32 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
................................................................................

}

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

















|






|

|













|







 







|










>










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
...
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
#
# 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.6 1999/03/24 02:49:33 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::workingDir"} {
    set origPkgDir [file join $::tcltest::testsDir pkg]
    set newPkgDir [file join $::tcltest::workingDir 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::workingDir pkg1]

namespace eval pkgtest {
    # Namespace for procs we can discard
}

# pkgtest::parseArgs --
#
................................................................................
    } {0 {}}
} else {
    puts "Skipping pkgMkIndex-10.1 (index of DLL and script)"
}

# cleanup
namespace delete pkgtest
cd $::tcltest::workingDir
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.

18
19
20
21
22
23
24

25
26
27
28
29
30
31
32
33
34
test platform-1.1 {TclpSetVariables: tcl_platform} {
    lsort [array names tcl_platform]
} {byteOrder machine os osVersion platform user}

# cleanup
::tcltest::cleanupTests
return

















>










18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
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
...
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 ""}
................................................................................
} 20

# cleanup
catch {rename t1 ""}
catch {rename foo ""}
::tcltest::cleanupTests
return


















|







 







>











10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
# 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.5 1999/03/24 02:49:34 hershey Exp $

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

catch {rename t1 ""}
catch {rename foo ""}
................................................................................
} 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
...
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 ""}
................................................................................
} {procedure "t": formal parameter "z" has default value inconsistent with precompiled body}

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


















|







 







>











9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
#
# 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.6 1999/03/24 02:49:34 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 ""}
................................................................................
} {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
..
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
................................................................................
test pwd-1.2 {simple pwd} {
	expr [string length pwd]>0
} 1

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
# 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.4 1999/03/24 02:49:35 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
................................................................................
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
...
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
................................................................................


doing 0 "flush"			;# to flush any leftover complaints

# cleanup
::tcltest::cleanupTests
return








|







 








>
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
...
891
892
893
894
895
896
897
898
899
# 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.6 1999/03/24 02:49:35 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
................................................................................


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
...
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} {
................................................................................
    }
    set x done
} {done}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
# 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.9 1999/03/24 02:49:36 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} {
................................................................................
    }
    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
...
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 {
................................................................................
} {1 {unable to open key: Access is denied.}}


# cleanup
unset hostname
::tcltest::cleanupTests
return


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
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.7 1999/03/24 02:49:36 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 {
................................................................................
} {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

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

















|







 







>










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
172
# 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.3 1999/03/24 02:49:37 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
...
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
................................................................................
} {called "incr" with too many arguments}

# cleanup
catch {rename incr {}}
catch {rename incr.old incr}
::tcltest::cleanupTests
return



















|







 







>












7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
167
168
169
170
171
172
173
174
175
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 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 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.5 1999/03/24 02:49:37 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
................................................................................
} {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
...
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
................................................................................
    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


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
#
# 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.5 1999/03/24 02:49:38 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
................................................................................
    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.

79
80
81
82
83
84
85

86
87
88
89
90
91
92
93
94
95
96
    catch {testsetobjerrorcode 1 2 3 4 5}
    list [set errorCode]
} {{1 2 3 4 5}}

# cleanup
::tcltest::cleanupTests
return


















>











79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
    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
...
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
................................................................................


}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
#
# 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.6 1999/03/24 02:49:38 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
................................................................................


}

# cleanup
::tcltest::cleanupTests
return












Changes to tests/scan.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
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
................................................................................
    scan "1234567890123456789 13.6" "%s %f" a b
    set b
} 13.6

# cleanup
::tcltest::cleanupTests
return




















|







 







>













7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
# 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.7 1999/03/24 02:49:39 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
................................................................................
    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
..
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

................................................................................
    catch {tcl_startOfPreviousWord x {[BUG]}}
    CB
} 0

# cleanup
::tcltest::cleanupTests
return

















|







 







>










6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
# 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.4 1999/03/24 02:49:39 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

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

................................................................................
catch {unset b}
catch {unset c}
catch {unset aVaRnAmE}

# cleanup
::tcltest::cleanupTests
return 


















|







 







>











9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
# 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.5 1999/03/24 02:49:40 hershey Exp $

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

proc ignore args {}

................................................................................
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
...
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}
................................................................................
catch {unset a}
catch {unset b}
catch {unset i}
catch {unset x}
catch {unset z}
::tcltest::cleanupTests
return 


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
#
# 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.5 1999/03/24 02:49:40 hershey Exp $

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

catch {unset x}
catch {unset i}
................................................................................
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
....
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
................................................................................
   flush $commandSocket
}
catch {close $commandSocket}
catch {close $remoteProcChan}
::tcltest::cleanupTests
flush stdout
return

















|







 







>










6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
#
# 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.8 1999/03/24 02:49:41 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
................................................................................
   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
...
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"
................................................................................
    string length $x
} 5

# cleanup
catch {::tcltest::removeFile source.file}
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
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-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.5 1999/03/24 02:49:41 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"
................................................................................
    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
..
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 "
................................................................................
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


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
# 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.4 1999/03/24 02:49:42 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 "
................................................................................
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
..
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.

................................................................................
    rename recurse {}
    set rv
} {too many nested calls to Tcl_EvalObj (infinite loop?)}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
..
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
# 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.3 1999/03/24 02:49:42 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.

................................................................................
    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
...
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
................................................................................
test string-15.2 {error conditions} {
    list [catch {string} msg] $msg
} {1 {wrong # args: should be "string option arg ?arg ...?"}}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
# 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.5 1999/03/24 02:49:43 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
................................................................................
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
...
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
}

................................................................................
} {5 10 5 5 abcde}

testobj freeallvars

# cleanup
::tcltest::cleanupTests
return


















|







 







>











8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
#
# 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.5 1999/03/24 02:49:43 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
}

................................................................................
} {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
...
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
................................................................................
    set x 123
    subst -nov -nob -noc {abc $x [expr 1+2] \\\x41}
} {abc $x [expr 1+2] \\\x41}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
# 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.5 1999/03/24 02:49:44 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
................................................................................
    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
...
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}
................................................................................
        default {set msg 2}
    }
} {}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
# 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.6 1999/03/24 02:49:44 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}
................................................................................
        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
...
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} {
................................................................................
    list $x $msg $errorCode
} {1 ERR CODE}
ThreadReap

# cleanup
::tcltest::cleanupTests
return


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
#
# 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.4 1999/03/24 02:49:44 hershey Exp $

if {[info command testthread] == ""} {
    puts "skipping: tests require the testthread command"
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
................................................................................
    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
...
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] {
................................................................................
    update
    set x
} {before after2 after4}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
#
# 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.5 1999/03/24 02:49:45 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] {
................................................................................
    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
...
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
................................................................................

catch {unset x}
catch {unset y}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
# 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.5 1999/03/24 02:49:45 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
................................................................................

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
...
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
...
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 {}
................................................................................
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}
................................................................................
    set r
} {1 {error getting working directory name:}}

# cleanup
cleanup
::tcltest::cleanupTests
return


















|







 







|







 







>











5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
...
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
# 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.6 1999/03/24 02:49:46 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 {}
................................................................................
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} {unixOnly notRoot} {
    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}
................................................................................
    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
..
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\""
................................................................................
} $absPath

# cleanup
catch {set env(PATH) $oldPath}
file delete junk
::tcltest::cleanupTests
return


















|







 







>











5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
..
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
# 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.4 1999/03/24 02:49:46 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\""
................................................................................
} $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
...
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
................................................................................
} {}
    
# cleanup
catch {unset env(TCL_LIBRARY); set env(TCL_LIBRARY) $oldlibrary}
catch {unset env(LANG); set env(LANG) $oldlang}
::tcltest::cleanupTests
return


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
#
# 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.6 1999/03/24 02:49:47 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
................................................................................
} {}
    
# 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
..
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..."
................................................................................
} {1 {can't wait for variable "x":  would wait forever}}

# cleanup
file delete foo
file delete foo2
::tcltest::cleanupTests
return


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
#
# 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.5 1999/03/24 02:49:47 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..."
................................................................................
} {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
..
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}
................................................................................
} {1 {unknown failed} NONE}

# cleanup
catch {rename unknown {}}
catch {rename unknown.old unknown}
::tcltest::cleanupTests
return 


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
# 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.5 1999/03/24 02:49:48 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}
................................................................................
} {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
...
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]
................................................................................
a2
test uplevel-5.1 {info level} {set x} 1
test uplevel-5.2 {info level} {set y} a3

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
# 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.5 1999/03/24 02:49:48 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]
................................................................................
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
...
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}
................................................................................
    } {1234}
}
catch {unset a}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
# 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.5 1999/03/24 02:49:48 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}
................................................................................
    } {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
...
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
................................................................................

test utf-23.1 {TclUniCharIsSpace} {
} {}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
#
# 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.6 1999/03/24 02:49:49 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
................................................................................

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

................................................................................
} {1 {can't set "tcl_precision": improper value for precision} 12}

set tcl_precision 12

# cleanup
::tcltest::cleanupTests
return


















|







 







>











3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
...
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
#
# 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.6 1999/03/24 02:49:49 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
}

................................................................................
} {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
...
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 {unset a}
catch {unset xxxxx}
catch {unset aaaaa}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
#
# 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.7 1999/03/24 02:49:50 hershey Exp $
#

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

catch {rename p ""}
................................................................................
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
...
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
................................................................................
    set x 1
    while {$x} {set x 0}
} {}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
# 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.5 1999/03/24 02:49:50 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
................................................................................
    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
...
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.

................................................................................
    }
    set a
} {1 3}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
#
# 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.5 1999/03/24 02:49:51 hershey Exp $

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

# Basic "while" operation.

................................................................................
    }
    set a
} {1 3}

# cleanup
::tcltest::cleanupTests
return












Changes to tests/winConsole.test.

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
..
44
45
46
47
48
49
50

# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winConsole.test,v 1.1.2.1 1999/03/24 00:04:30 redman Exp $

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


test winConsole-1.1 {Console file channel: non-blocking gets} \
................................................................................

}  "abcdef"

#cleanup

::tcltest::cleanupTests
return







|







 







>
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
..
44
45
46
47
48
49
50
51
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winConsole.test,v 1.1.2.2 1999/03/24 02:49:51 hershey Exp $

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


test winConsole-1.1 {Console file channel: non-blocking gets} \
................................................................................

}  "abcdef"

#cleanup

::tcltest::cleanupTests
return

Changes to tests/winFCmd.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
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}} {
................................................................................
#    }
#}

# cleanup
cleanup
::tcltest::cleanupTests
return


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
#
# 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.6 1999/03/24 02:49:52 hershey Exp $
#

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

proc createfile {file {string a}} {
................................................................................
#    }
#}

# cleanup
cleanup
::tcltest::cleanupTests
return












Changes to tests/winFile.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
46
47
48
49
50
51
52

53
54
55
56
57
58
59
60
61
62
63
#
# 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: winFile.test,v 1.1.2.4 1999/03/23 20:07:06 hershey Exp $

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

test winFile-1.1 {TclpGetUserHome} {pcOnly} {
    list [catch {glob ~nosuchuser} msg] $msg
................................................................................
test winFile-1.3 {TclpGetUserHome} {nt nonPortable} {
    catch {glob [email protected]}
} {0}

# cleanup
::tcltest::cleanupTests
return


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
#
# 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: winFile.test,v 1.1.2.5 1999/03/24 02:49:52 hershey Exp $

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

test winFile-1.1 {TclpGetUserHome} {pcOnly} {
    list [catch {glob ~nosuchuser} msg] $msg
................................................................................
test winFile-1.3 {TclpGetUserHome} {nt nonPortable} {
    catch {glob [email protected]}
} {0}

# cleanup
::tcltest::cleanupTests
return












Changes to tests/winNotify.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
152
153
154
155
156
157
158

159
160
161
162
163
164
165
166
167
168
169
#
# 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: winNotify.test,v 1.1.2.4 1999/03/23 20:07:06 hershey Exp $

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

# There is no explicit test for InitNotifier or NotifierExitHandler

................................................................................
} {1 1}

# Tcl_DoOneEvent is tested by the timer.test, io.test, and event.test files

# cleanup
::tcltest::cleanupTests
return


















|







 







>











6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
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: winNotify.test,v 1.1.2.5 1999/03/24 02:49:52 hershey Exp $

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

# There is no explicit test for InitNotifier or NotifierExitHandler

................................................................................
} {1 1}

# Tcl_DoOneEvent is tested by the timer.test, io.test, and event.test files

# cleanup
::tcltest::cleanupTests
return












Changes to tests/winPipe.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
396
397
398
399
400
401
402

403
404
405
406
407
408
409
410
411
412
#
# 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: winPipe.test,v 1.1.2.7 1999/03/23 20:07:06 hershey Exp $

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

set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
set cat16 [file join  $bindir cat16.exe]
................................................................................
    unset env(TEMP)
}

# cleanup
file delete big little stdout stderr nothing echoArgs.tcl
::tcltest::cleanupTests
return

















|







 







>










8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
#
# 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: winPipe.test,v 1.1.2.8 1999/03/24 02:49:53 hershey Exp $

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

set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
set cat16 [file join  $bindir cat16.exe]
................................................................................
    unset env(TEMP)
}

# cleanup
file delete big little stdout stderr nothing echoArgs.tcl
::tcltest::cleanupTests
return