Tcl Source Code

Check-in [4c4431ec5e]
Login
Core Home Timeline Branches Tags Tickets Wiki Clone or Download
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:-now all test files that skip tests by returning early (which ideally they shouldn't do) call ::tcltest::cleanupTests before returning.

-the defs.tcl file has one new constraint: userInteraction, used by tests that require user interaction. The next putback will include an updated version of the "visual" test file to use this mechanism.

Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-1-branch-old
Files: files | file ages | folders
SHA1:4c4431ec5ed60cca0ca4d8fb9bccf614a17250b4
User & Date: hershey 1999-03-26 19:13:55
Context
1999-03-26
19:46
--enable-shared is now the default that builds Tcl as a shared library. Use --disable-shared and ... check-in: 554e3ea7ea user: suresh tags: core-8-1-branch-old
19:13
-now all test files that skip tests by returning early (which ideally they shouldn't do) call ::t... check-in: 4c4431ec5e user: hershey tags: core-8-1-branch-old
02:24
* tests/interp.test: * generic/tclInterp.c (AliasObjCmd): Changed so aliases are invoked at current ... check-in: 27603c3b06 user: stanton tags: core-8-1-branch-old
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to tests/README. 

1
2
3
4
5
6
7
8
9
10
..
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
...
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
...
397
398
399
400
401
402
403


404






README -- Tcl test suite design document.

RCS: @(#) $Id: README,v 1.1.2.5 1999/03/24 19:26:02 hershey Exp $

Contents:
---------

    1. Introduction
    2. Definitions file
    3. Writing a new test
................................................................................

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

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

    (c) start up tcltest in this directory, then "source" the test
        file (for example, type "source parse.test").  To run all
	of the tests, type "source all.tcl".  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
................................................................................
unixCrash       test crashes if it's run on UNIX.  This flag is used
		to temporarily disable a test.
pcCrash 	test crashes if it's run on Windows.  This flag is
		used to temporarily disable a test.
macCrash 	test crashes if it's run on a Mac.  This flag is used
		to temporarily disable a test.











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








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


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

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

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

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

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











|







 







|
<
<
|





|




>







 







>
>
>
>
>
>
>
>
>
>






|
>
>

>
>
>
>
>

|
<
<
<
<
<
<
<
|
<







 







>
>

>
>
>
>
>

1
2
3
4
5
6
7
8
9
10
..
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
...
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
...
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419

README -- Tcl test suite design document.

RCS: @(#) $Id: README,v 1.1.2.6 1999/03/26 19:13:55 hershey Exp $

Contents:
---------

    1. Introduction
    2. Definitions file
    3. Writing a new test
................................................................................

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

	-constraints <list>  tests with any constraints in <list> will


			     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 after sourcing the defs.tcl file.
		  ::tcltest::matchingTests
		  ::tcltest::skippingTests
		  ::tcltest::testConfig(nonPortable)
		  ::tcltest::testConfig(knownBug)
		  ::tcltest::testConfig(userInteractive)

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
................................................................................
unixCrash       test crashes if it's run on UNIX.  This flag is used
		to temporarily disable a test.
pcCrash 	test crashes if it's run on Windows.  This flag is
		used to temporarily disable a test.
macCrash 	test crashes if it's run on a Mac.  This flag is used
		to temporarily disable a test.

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

knownBug	test is known to fail and the bug is not yet
                fixed.  This constraint always causes tests to be
                skipped unless the user specifies otherwise.  See the
                "Introduction" section for more details.

nonPortable	test can only be run in the master Tcl/Tk
		development environment.  Some tests are inherently
		non-portable because they depend on things like word
		length, file system configuration, window manager,
		etc.  These tests are only run in the main Tcl
		development directory where the configuration is
		well known.  This constraint always causes tests to be
		skipped unless the user specifies otherwise.  See the
		"Introduction" section for more details.

userInteraction test requires interaction from the user.  This
                constraint always causes tests to be skipped unless
                the user specifies otherwise.  See the "Introduction"
                section for more details. 

interactive	test can only be run in if the interpreter is in
		interactive mode, that is the global tcl_interactive







		variable is set to 1.


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

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

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

4) The "all", "defs", and "visual" files are now called "all.tcl",
   "defs.tcl", and "visual_bb.test", respectively.

5) Instead of creating a doAllTests file in the tests directory, to
   run all nonPortable tests, just use the "-constraints nonPortable"
   command line flag.  If you are running interactively, you can set
   the ::tcltest::testConfig(nonPortable) variable to 1 (after
   sourcing the defs.tcl file).

Changes to tests/assocd.test. 

7
8
9
10
11
12
13
14




15
16
17
18

19
20
21
22
23
24
25
26
27
28
29
30
31
32

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

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

test assocd-1.1 {testing setting assoc data} {
   testsetassocdata a 1
} ""
test assocd-1.2 {testing setting assoc data} {
   testsetassocdata a 2
} ""
test assocd-1.3 {testing setting assoc data} {







|
>
>
>
>




>



<
<
<
<








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

# 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.6 1999/03/26 19:13:55 hershey Exp $

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

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."
    ::tcltest::cleanupTests
    return
}





test assocd-1.1 {testing setting assoc data} {
   testsetassocdata a 1
} ""
test assocd-1.2 {testing setting assoc data} {
   testsetassocdata a 2
} ""
test assocd-1.3 {testing setting assoc data} {

Changes to tests/async.test. 

7
8
9
10
11
12
13
14




15
16
17
18

19
20
21
22
23
24
25
26
27
28
29
30
31
32

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

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

proc async1 {result code} {
    global aresult acode
    set aresult $result
    set acode $code
    return "new result"
}
proc async2 {result code} {







|
>
>
>
>




>



<
<
<
<








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

# 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.6 1999/03/26 19:13:56 hershey Exp $

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

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."
    ::tcltest::cleanupTests
    return
}





proc async1 {result code} {
    global aresult acode
    set aresult $result
    set acode $code
    return "new result"
}
proc async2 {result code} {

Changes to tests/cmdInfo.test. 

9
10
11
12
13
14
15
16




17
18
19
20

21
22
23
24
25
26
27
28
29
30
31
32
33
34

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

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

test cmdinfo-1.1 {command procedure and clientData} {
    testcmdinfo create x1
    testcmdinfo get x1
} {CmdProc1 original CmdDelProc1 original :: stringProc}
test cmdinfo-1.2 {command procedure and clientData} {
    testcmdinfo create x1
    x1







|
>
>
>
>




>



<
<
<
<








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

# 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.6 1999/03/26 19:13:56 hershey Exp $

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

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





test cmdinfo-1.1 {command procedure and clientData} {
    testcmdinfo create x1
    testcmdinfo get x1
} {CmdProc1 original CmdDelProc1 original :: stringProc}
test cmdinfo-1.2 {command procedure and clientData} {
    testcmdinfo create x1
    x1

Changes to tests/dcall.test. 

7
8
9
10
11
12
13
14




15
16
17
18

19
20
21
22
23
24
25
26
27
28
29
30
31
32

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

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

test dcall-1.1 {deletion callbacks} {
    lsort -increasing [testdcall 1 2 3]
} {1 2 3}
test dcall-1.2 {deletion callbacks} {
    testdcall
} {}
test dcall-1.3 {deletion callbacks} {







|
>
>
>
>




>



<
<
<
<








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

# 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.6 1999/03/26 19:13:57 hershey Exp $

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

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





test dcall-1.1 {deletion callbacks} {
    lsort -increasing [testdcall 1 2 3]
} {1 2 3}
test dcall-1.2 {deletion callbacks} {
    testdcall
} {}
test dcall-1.3 {deletion callbacks} {

Changes to tests/defs.tcl. 

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
186
187
188
189
190
191
192
193
194
195
196
197






198
199
200
201
202
203
204
...
311
312
313
314
315
316
317
318


319
320
321
322
323
324
325
...
370
371
372
373
374
375
376
377
378

379
380
381
382
383
384
385
386
387
388
389
390
391
392
393

#	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.7 1999/03/25 17:20:00 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 x [list [.t bbox 1.3] [.t bbox 2.5]]
	destroy .t
	if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} {
	    set ::tcltest::testConfig(fonts) 0
	}
    }

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

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







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

    # Some tests must be skipped if you are running as root on Unix.
    # Other tests can only be run if you are running as root on Unix.
    set ::tcltest::testConfig(root) 0
................................................................................

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

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

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

    # Use the -constraints flag, if given, to turn on the following
    # constraints:  knownBug and nonPortable

    if {[info exists flag(-constraints)]} {
	set constrList $flag(-constraints)
    } else {
	set constrList {}
    }
    foreach elt [list knownBug nonPortable] {
	set ::tcltest::testConfig($elt) \
		[expr {[lsearch -exact $constrList $elt] != -1}]
    }
}

::tcltest::processCmdLineArgs


# ::tcltest::cleanupTests --







|







 







|
|



>
>
>
>
>
>







 







|
>
>







 







|
|
>

|
<
|
|
<
<
<








7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
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
...
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
...
378
379
380
381
382
383
384
385
386
387
388
389

390
391



392
393
394
395
396
397
398

#	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.8 1999/03/26 19:13:57 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 x [list [.t bbox 1.3] [.t bbox 2.5]]
	destroy .t
	if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} {
	    set ::tcltest::testConfig(fonts) 0
	}
    }

    # Skip empty tests
    set ::tcltest::testConfig(emptyTest) 0

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

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

    # Some tests require user interaction.
    set ::tcltest::testConfig(userInteraction) 0

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

    # Some tests must be skipped if you are running as root on Unix.
    # Other tests can only be run if you are running as root on Unix.
    set ::tcltest::testConfig(root) 0
................................................................................

::tcltest::initConfig


# ::tcltest::processCmdLineArgs --
#
#	Use command line args to set the verbose, skippingTests, and
#	matchingTests variables.  This procedure must be run after
#	constraints are initialized, because some constraints can be
#	overridden.
#
# Arguments:
#	none
#
# Results:
#	::tcltest::verbose is set to <value>

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

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

    # Use the -constraints flag, if given, to turn on constraints that are
    # turned off by default: userInteractive knownBug nonPortable.  This
    # code fragment must be run after constraints are initialized.
    if {[info exists flag(-constraints)]} {
	foreach elt $flag(-constraints) {

	    set ::tcltest::testConfig($elt) 1
	}



    }
}

::tcltest::processCmdLineArgs


# ::tcltest::cleanupTests --

Changes to tests/dstring.test. 

7
8
9
10
11
12
13
14




15
16
17
18

19
20
21
22
23
24
25
26
27
28
29
30
31
32

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

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

test dstring-1.1 {appending and retrieving} {
    testdstring free
    testdstring append "abc" -1
    list [testdstring get] [testdstring length]
} {abc 3}
test dstring-1.2 {appending and retrieving} {
    testdstring free







|
>
>
>
>




>



<
<
<
<








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

# 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.6 1999/03/26 19:13:58 hershey Exp $

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

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."
    ::tcltest::cleanupTests
    return
}





test dstring-1.1 {appending and retrieving} {
    testdstring free
    testdstring append "abc" -1
    list [testdstring get] [testdstring length]
} {abc 3}
test dstring-1.2 {appending and retrieving} {
    testdstring free

Changes to tests/event.test. 

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
..
90
91
92
93
94
95
96
97

98
99
100
101
102
103
104
...
115
116
117
118
119
120
121
122

123
124
125
126
127
128
129
...
134
135
136
137
138
139
140
141

142
143
144
145
146
147
148
...
495
496
497
498
499
500
501
502

503
504
505
506
507
508
509
510
511
512
513
514
515
516

517
518
519
520
521
522
523

#
# 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.6 1999/03/24 04:25:42 stanton Exp $

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

set ::tcltest::testConfig(testfilehandler) \
	[expr {[info commands testfilehandler] != {}}]
................................................................................
    lappend result [testfilehandler counts 1]
    testfilehandler create 1 off off
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler close
    set result
} {{0 1} {1 1} {1 2} {0 0}}
test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} {testfilehandler nonPortable} {

    testfilehandler close
    testfilehandler create 0 readable writable
    testfilehandler fillpartial 0
    set result ""
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]
    testfilehandler close
................................................................................
    testfilehandler fillpartial 1
    testfilehandler windowevent
    set result [testfilehandler counts 1]
    testfilehandler close
    set result
} {0 0}

test event-4.1 {FileHandlerEventProc, race between event and disabling} {testfilehandler nonPortable} {

    update
    testfilehandler close
    testfilehandler create 2 disabled disabled
    testfilehandler create 1 readable writable
    testfilehandler fillpartial 1
    set result ""
    testfilehandler oneevent
................................................................................
    lappend result [testfilehandler counts 1]
    testfilehandler create 1 disabled disabled
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler close
    set result
} {{0 1} {1 1} {1 2} {0 0}}
test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off} {testfilehandler nonPortable} {

    update
    testfilehandler close
    testfilehandler create 1 readable writable
    testfilehandler create 2 readable writable
    testfilehandler fillpartial 1
    testfilehandler fillpartial 2
    testfilehandler oneevent
................................................................................
    testfilehandler fillpartial 1
    set x "no timeout"
    set result [testfilehandler wait 1 readable 100]
    update
    testfilehandler close
    list $result $x
} {readable {no timeout}}
test event-13.4 {Tcl_WaitForFile procedure, writable} {testfilehandler nonPortable} {

    foreach i [after info] {
	after cancel $i
    }
    after 100 set x timeout
    testfilehandler close
    testfilehandler create 1 off off
    testfilehandler fill 1
    set x "no timeout"
    set result [testfilehandler wait 1 writable 0]
    update
    testfilehandler close
    list $result $x
} {{} {no timeout}}
test event-13.5 {Tcl_WaitForFile procedure, writable} {testfilehandler nonPortable} {

    foreach i [after info] {
	after cancel $i
    }
    after 100 set x timeout
    testfilehandler close
    testfilehandler create 1 off off
    testfilehandler fill 1







|







 







|
>







 







|
>







 







|
>







 







|
>













|
>








5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
..
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
...
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
...
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
...
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528

#
# 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.7 1999/03/26 19:13:58 hershey Exp $

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

set ::tcltest::testConfig(testfilehandler) \
	[expr {[info commands testfilehandler] != {}}]
................................................................................
    lappend result [testfilehandler counts 1]
    testfilehandler create 1 off off
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler close
    set result
} {{0 1} {1 1} {1 2} {0 0}}
test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} \
	{testfilehandler nonPortable} {
    testfilehandler close
    testfilehandler create 0 readable writable
    testfilehandler fillpartial 0
    set result ""
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]
    testfilehandler close
................................................................................
    testfilehandler fillpartial 1
    testfilehandler windowevent
    set result [testfilehandler counts 1]
    testfilehandler close
    set result
} {0 0}

test event-4.1 {FileHandlerEventProc, race between event and disabling} \
	{testfilehandler nonPortable} {
    update
    testfilehandler close
    testfilehandler create 2 disabled disabled
    testfilehandler create 1 readable writable
    testfilehandler fillpartial 1
    set result ""
    testfilehandler oneevent
................................................................................
    lappend result [testfilehandler counts 1]
    testfilehandler create 1 disabled disabled
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler close
    set result
} {{0 1} {1 1} {1 2} {0 0}}
test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off} \
	{testfilehandler nonPortable} {
    update
    testfilehandler close
    testfilehandler create 1 readable writable
    testfilehandler create 2 readable writable
    testfilehandler fillpartial 1
    testfilehandler fillpartial 2
    testfilehandler oneevent
................................................................................
    testfilehandler fillpartial 1
    set x "no timeout"
    set result [testfilehandler wait 1 readable 100]
    update
    testfilehandler close
    list $result $x
} {readable {no timeout}}
test event-13.4 {Tcl_WaitForFile procedure, writable} \
	{testfilehandler nonPortable} {
    foreach i [after info] {
	after cancel $i
    }
    after 100 set x timeout
    testfilehandler close
    testfilehandler create 1 off off
    testfilehandler fill 1
    set x "no timeout"
    set result [testfilehandler wait 1 writable 0]
    update
    testfilehandler close
    list $result $x
} {{} {no timeout}}
test event-13.5 {Tcl_WaitForFile procedure, writable} \
	{testfilehandler nonPortable} {
    foreach i [after info] {
	after cancel $i
    }
    after 100 set x timeout
    testfilehandler close
    testfilehandler create 1 off off
    testfilehandler fill 1

Changes to tests/fCmd.test. 

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

23
24
25
26
27
28
29
30

31
32
33
34
35
36
37
...
592
593
594
595
596
597
598
599

600
601
602
603
604
605
606
607
608
609
610
611

#
# 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} {
    puts "This application hasn't been compiled with the \"testgetplatform\""
    puts "command, therefore I am skipping all of these tests."

    return
}

set platform [testgetplatform]

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

    return
}

# Several tests require need to match results against the unix username
set user {}
if {$tcl_platform(platform) == "unix"} {
    catch {set user [exec whoami]}
................................................................................
    glob td* /tmp/td1/t*
} {/tmp/td1/td2}
test fCmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} \
	{unixOnly notRoot} {
    cleanup
    file mkdir foo/bar
    file attr foo -perm 040555
    set msg [list [catch {file rename foo/bar /tmp} msg] $msg]

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







|









>








>







 







|
>



|
|








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
...
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614

#
# 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.8 1999/03/26 19:13:59 hershey Exp $
#

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

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

set platform [testgetplatform]

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

# Several tests require need to match results against the unix username
set user {}
if {$tcl_platform(platform) == "unix"} {
    catch {set user [exec whoami]}
................................................................................
    glob td* /tmp/td1/t*
} {/tmp/td1/td2}
test fCmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} \
	{unixOnly notRoot} {
    cleanup
    file mkdir foo/bar
    file attr foo -perm 040555
    set catchResult [catch {file rename foo/bar /tmp} msg]
    set msg [lindex [split $msg :] end]
    catch {file delete /tmp/bar}
    catch {file attr foo -perm 040777}
    catch {file delete -force foo}
    list $catchResult $msg
} {1 { permission denied}}
test fCmd-6.31 {CopyRenameOneFile: TclpDeleteFile passed} \
	{unixOnly notRoot xdev} {
    catch {cleanup /tmp}
    file mkdir /tmp/td1
    createfile /tmp/td1/tf1
    file rename /tmp/td1/tf1 tf1
    list [file exists /tmp/td1/tf1] [file exists tf1]

Changes to tests/fileName.test. 

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

22
23
24
25
26
27
28

#
# 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\""
    puts "command, so I can't test the filename conversion procedures."

    return 
} 

global env
set platform [testgetplatform]

test filename-1.1 {Tcl_GetPathType: unix} {







|








>








6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

#
# 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.6 1999/03/26 19:13:59 hershey Exp $

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

if {[info commands testsetplatform] == {}} {
    puts "This application hasn't been compiled with the \"testsetplatform\""
    puts "command, so I can't test the filename conversion procedures."
    ::tcltest::cleanupTests
    return 
} 

global env
set platform [testgetplatform]

test filename-1.1 {Tcl_GetPathType: unix} {

Changes to tests/history.test. 

7
8
9
10
11
12
13
14
15




16
17
18

19
20
21
22
23
24
25
26
27
28
29
30
31
32

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

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

set num [history nextid]
history keep 3
history add {set a 12345}
history add {set b [format {A test %s} string]}
history add {Another test}

# "history event"







|

>
>
>
>



>



<
<
<
<








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

# 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.6 1999/03/26 19:14:00 hershey Exp $
  
if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {history}]} {
    puts stdout "This version of Tcl was built without the history command;\n"
    puts stdout "history tests will be skipped.\n"
    ::tcltest::cleanupTests
    return
}





set num [history nextid]
history keep 3
history add {set a 12345}
history add {set b [format {A test %s} string]}
history add {Another test}

# "history event"

Changes to tests/httpold.test. 

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

23
24
25
26
27
28
29

30
31
32
33
34
35
36
...
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: 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]} {
	catch {puts "Cannot load http 1.0 package"}

	return
    } else {
	catch {puts "Running http 1.0 tests in slave interp"}
	set interp [interp create httpold]
	$interp eval [list set httpold "running"]
	$interp eval [list source [info script]]
	interp delete $interp

	return
    }
}

############### The httpd_ procedures implement a stub http server. ########
proc httpd_init {{port 8015}} {
    socket -server httpdAccept $port
................................................................................
}
##################### end server ###########################

set port 8010
if [catch {httpd_init $port} listen] {
    puts "Cannot start http server, http test skipped"
    unset port

    return
}

test http-1.1 {http_config} {
    http_config
} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}}








|








>







>







 







>








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
...
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195

# 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.6 1999/03/26 19:14:01 hershey Exp $

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

if {[catch {package require http 1.0}]} {
    if {[info exist httpold]} {
	catch {puts "Cannot load http 1.0 package"}
	::tcltest::cleanupTests
	return
    } else {
	catch {puts "Running http 1.0 tests in slave interp"}
	set interp [interp create httpold]
	$interp eval [list set httpold "running"]
	$interp eval [list source [info script]]
	interp delete $interp
	::tcltest::cleanupTests
	return
    }
}

############### The httpd_ procedures implement a stub http server. ########
proc httpd_init {{port 8015}} {
    socket -server httpdAccept $port
................................................................................
}
##################### end server ###########################

set port 8010
if [catch {httpd_init $port} listen] {
    puts "Cannot start http server, http test skipped"
    unset port
    ::tcltest::cleanupTests
    return
}

test http-1.1 {http_config} {
    http_config
} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}}

Changes to tests/indexObj.test. 

4
5
6
7
8
9
10
11




12
13
14
15

16
17
18
19
20
21
22
23
24
25
26
27
28
29

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

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

test indexObj-1.1 {exact match} {
    testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} {
    testindexobj 1 1 abc abc def xyz alm
} {0}
test indexObj-1.3 {exact match} {







|
>
>
>
>




>



<
<
<
<








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

#
# 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.6 1999/03/26 19:14:01 hershey Exp $

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

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





test indexObj-1.1 {exact match} {
    testindexobj 1 1 xyz abc def xyz alm
} {2}
test indexObj-1.2 {exact match} {
    testindexobj 1 1 abc abc def xyz alm
} {0}
test indexObj-1.3 {exact match} {

Changes to tests/link.test. 

7
8
9
10
11
12
13
14




15
16
17
18

19
20
21
22
23
24
25
26
27
28
29
30
31
32

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

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

foreach i {int real bool string} {
    catch {unset $i}
}
test link-1.1 {reading C variables from Tcl} {
    testlink delete
    testlink set 43 1.23 4 -
    testlink create 1 1 1 1







|
>
>
>
>




>



<
<
<
<








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

# 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.6 1999/03/26 19:14:01 hershey Exp $

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

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."
    ::tcltest::cleanupTests
    return
}





foreach i {int real bool string} {
    catch {unset $i}
}
test link-1.1 {reading C variables from Tcl} {
    testlink delete
    testlink set 43 1.23 4 -
    testlink create 1 1 1 1

Changes to tests/listObj.test. 

7
8
9
10
11
12
13
14




15
16
17
18

19
20
21
22
23
24
25
26
27
28
29
30
31
32

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

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

catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} {
    set t [testobj types]
    set first [string first "list" $t]
    set result [expr {$first != -1}]
} {1}








|
>
>
>
>




>



<
<
<
<








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

#
# 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.6 1999/03/26 19:14:02 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 \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    ::tcltest::cleanupTests
    return
}





catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} {
    set t [testobj types]
    set first [string first "list" $t]
    set result [expr {$first != -1}]
} {1}

Changes to tests/load.test. 

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

24
25
26
27
28
29
30

#
# 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.7 1999/03/25 17:20:01 hershey Exp $

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

# Figure out what extension is used for shared libraries on this
# platform.

if {$tcl_platform(platform) == "macintosh"} {
    puts "can't run dynamic library tests on macintosh machines"

    return
}

# Tests require the existence of one of the DLLs in the dltest directory.
set ext [info sharedlibextension]
set testDir [file join [file dirname [info nameofexecutable]] dltest]
set x [file join $testDir pkga$ext]







|










>








6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

#
# Copyright (c) 1995 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics 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.8 1999/03/26 19:14:02 hershey Exp $

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

# Figure out what extension is used for shared libraries on this
# platform.

if {$tcl_platform(platform) == "macintosh"} {
    puts "can't run dynamic library tests on macintosh machines"
    ::tcltest::cleanupTests
    return
}

# Tests require the existence of one of the DLLs in the dltest directory.
set ext [info sharedlibextension]
set testDir [file join [file dirname [info nameofexecutable]] dltest]
set x [file join $testDir pkga$ext]

Changes to tests/obj.test. 

7
8
9
10
11
12
13
14




15
16
17
18

19
20
21
22
23
24
25
26
27
28
29
30
31
32

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

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

test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} {
    set r 1
    foreach {t} {list boolean cmdName bytecode string int double} {
        set first [string first $t [testobj types]]
        set r [expr {$r && ($first != -1)}]
    }
    set result $r







|
>
>
>
>




>



<
<
<
<








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

#
# 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.6 1999/03/26 19:14:03 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 \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    ::tcltest::cleanupTests
    return
}





test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} {
    set r 1
    foreach {t} {list boolean cmdName bytecode string int double} {
        set first [string first $t [testobj types]]
        set r [expr {$r && ($first != -1)}]
    }
    set result $r

Changes to tests/parse.test. 

4
5
6
7
8
9
10
11




12
13
14
15

16
17
18
19
20
21
22
23
24
25
26
27
28
29

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

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

test parse-1.1 {Tcl_ParseCommand procedure, computing string length} {
    testparser [bytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-1.2 {Tcl_ParseCommand procedure, computing string length} {
    testparser "foo bar" -1
} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}}
test parse-1.3 {Tcl_ParseCommand procedure, leading space} {







|
>
>
>
>




>



<
<
<
<








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

#
# 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.11 1999/03/26 19:14:03 hershey Exp $

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

if {[info commands testparser] == {}} {
    puts "This application hasn't been compiled with the \"testparser\""
    puts "command, so I can't test the Tcl parser."
    ::tcltest::cleanupTests
    return 
}





test parse-1.1 {Tcl_ParseCommand procedure, computing string length} {
    testparser [bytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-1.2 {Tcl_ParseCommand procedure, computing string length} {
    testparser "foo bar" -1
} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}}
test parse-1.3 {Tcl_ParseCommand procedure, leading space} {

Changes to tests/parseExpr.test. 

4
5
6
7
8
9
10
11




12
13
14
15
16
17
18
19
20

21
22
23
24
25
26
27
28
29
30
31
32
33
34

#
# 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] == {}} {
    puts "This application hasn't been compiled with the \"testexprparser\""
    puts "command, so I can't test the Tcl expression parser."

    return 
}

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

test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} {
    testexprparser [bytestring "1+2\0 +3"] -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} {
    testexprparser "1  + 2" -1
} {- {} 0 subexpr {1  + 2} 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-1.3 {Tcl_ParseExpr procedure, error getting initial lexeme} {nonPortable} {







|
>
>
>
>









>



<
<
<
<








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

#
# 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.5 1999/03/26 19:14:04 hershey Exp $

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

# Note that the Tcl expression parser (tclParseExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
# for example, that a math function actually exists, or that the operands
# of "<<" are integers.

if {[info commands testexprparser] == {}} {
    puts "This application hasn't been compiled with the \"testexprparser\""
    puts "command, so I can't test the Tcl expression parser."
    ::tcltest::cleanupTests
    return 
}





test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} {
    testexprparser [bytestring "1+2\0 +3"] -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} {
    testexprparser "1  + 2" -1
} {- {} 0 subexpr {1  + 2} 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-1.3 {Tcl_ParseExpr procedure, error getting initial lexeme} {nonPortable} {

Changes to tests/pid.test. 

7
8
9
10
11
12
13
14




15
16
17
18
19

20
21
22
23
24
25
26
27
28
29
30
31
32
33

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

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

catch {removeFile test1}

test pid-1.1 {pid command} {
    regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
} 1
test pid-1.2 {pid command} {unixOrPc unixExecs} {
    set f [open {| echo foo | cat >test1} w]







|
>
>
>
>





>



<
<
<
<








7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27




28
29
30
31
32
33
34

# Copyright (c) 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.6 1999/03/26 19:14:05 hershey Exp $

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

# 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"
    ::tcltest::cleanupTests
    return
}





catch {removeFile test1}

test pid-1.1 {pid command} {
    regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
} 1
test pid-1.2 {pid command} {unixOrPc unixExecs} {
    set f [open {| echo foo | cat >test1} w]

Changes to tests/proc.test. 

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
164
165
166
167
168
169
170

171
172
173
174
175
176
177

#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: 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 ""}
................................................................................
catch {rename p ""}
catch {rename {} ""}
catch {unset msg}

if {[catch {package require procbodytest}]} {
    puts "This application couldn't load the \"procbodytest\" package, so I"
    puts "can't test creation of procs whose bodies have type \"procbody\"."

    return
}

catch {rename p ""}
catch {rename t ""}

# Note that the test require that procedures whose body is used to create







|







 







>








9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178

#
# 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.7 1999/03/26 19:14:06 hershey Exp $

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

catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
................................................................................
catch {rename p ""}
catch {rename {} ""}
catch {unset msg}

if {[catch {package require procbodytest}]} {
    puts "This application couldn't load the \"procbodytest\" package, so I"
    puts "can't test creation of procs whose bodies have type \"procbody\"."
    ::tcltest::cleanupTests
    return
}

catch {rename p ""}
catch {rename t ""}

# Note that the test require that procedures whose body is used to create

Changes to tests/stringObj.test. 

8
9
10
11
12
13
14
15




16
17
18
19

20
21
22
23
24
25
26
27
28
29
30
31
32
33

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

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

test stringObj-1.1 {string type registration} {
    set t [testobj types]
    set first [string first "string" $t]
    set result [expr {$first != -1}]
} {1}

test stringObj-2.1 {Tcl_NewStringObj} {







|
>
>
>
>




>



<
<
<
<








8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27




28
29
30
31
32
33
34

#
# Copyright (c) 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.6 1999/03/26 19:14:06 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 \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    ::tcltest::cleanupTests
    return
}





test stringObj-1.1 {string type registration} {
    set t [testobj types]
    set first [string first "string" $t]
    set result [expr {$first != -1}]
} {1}

test stringObj-2.1 {Tcl_NewStringObj} {

Changes to tests/thread.test. 

6
7
8
9
10
11
12
13




14
15
16

17
18
19
20
21
22
23
24
25
26
27
28
29
30

#
# 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} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set mainthread [testthread names]
proc ThreadReap {} {
    global mainthread
    testthread errorproc ThreadNullError
    while {[llength [testthread names]] > 1} {
	foreach tid [testthread names] {
	    if {$tid != $mainthread} {







|
>
>
>
>



>



<
<
<
<








6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24




25
26
27
28
29
30
31

#
# Copyright (c) 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.5 1999/03/26 19:14:07 hershey Exp $

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

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





set mainthread [testthread names]
proc ThreadReap {} {
    global mainthread
    testthread errorproc ThreadNullError
    while {[llength [testthread names]] > 1} {
	foreach tid [testthread names] {
	    if {$tid != $mainthread} {

Changes to tests/unixFile.test. 

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20

21
22
23
24
25
26
27

# 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\""
    puts "command, so I can't test the Tcl_FindExecutable function"

    return
}

catch {
    set oldPath $env(PATH)
    close [open junk w]
    file attributes junk -perm 0777







|








>








5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28

# 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.5 1999/03/26 19:14:07 hershey Exp $

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

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testfindexecutable\""
    puts "command, so I can't test the Tcl_FindExecutable function"
    ::tcltest::cleanupTests
    return
}

catch {
    set oldPath $env(PATH)
    close [open junk w]
    file attributes junk -perm 0777

Changes to tests/unixNotfy.test. 

6
7
8
9
10
11
12
13
14
15
16
17
18




19
20

21
22
23
24
25
26
27
28
29
30
31
32

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

    return
}

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

test unixNotfy-1.1 {Tcl_DeleteFileHandler} {unixOnly} {
    catch {vwait x}
    set f [open foo w]
    fileevent $f writable {set x 1}
    vwait x







|





>
>
>
>


>

<
<
<
<








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

#
# 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.6 1999/03/26 19:14:08 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 {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

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




}

test unixNotfy-1.1 {Tcl_DeleteFileHandler} {unixOnly} {
    catch {vwait x}
    set f [open foo w]
    fileevent $f writable {set x 1}
    vwait x

Changes to tests/util.test. 

3
4
5
6
7
8
9
10




11
12
13
14

15
16
17
18
19
20
21
22
23
24
25
26
27
28

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

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

test util-1.1 {TclFindElement procedure - binary element in middle of list} {
    lindex {0 foo\x00help 1} 1
} "foo\x00help"
test util-1.2 {TclFindElement procedure - binary element at end of list} {
    lindex {0 foo\x00help} 1
} "foo\x00help"








|
>
>
>
>




>



<
<
<
<








3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22




23
24
25
26
27
28
29

#
# 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.7 1999/03/26 19:14:08 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 \"testobj\""
    puts "command, so I can't test the Tcl type and object support."
    ::tcltest::cleanupTests
    return
}





test util-1.1 {TclFindElement procedure - binary element in middle of list} {
    lindex {0 foo\x00help 1} 1
} "foo\x00help"
test util-1.2 {TclFindElement procedure - binary element at end of list} {
    lindex {0 foo\x00help} 1
} "foo\x00help"

This page was generated in about 0.052s by Fossil 2.9 [cbc21e5290] 2019-04-11 01:17:26