Tcl Source Code

Check-in [1467d41628]
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:skip tests that require test* commands when running in standard tclsh interp.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-1-branch-old
Files: files | file ages | folders
SHA1: 1467d416282c07247d8dbeccecd0b048fcc235bf
User & Date: hershey 1999-04-06 19:03:56
Context
1999-04-06
19:06
* generic/tclVar.c: * generic/tclEnv.c: Moved the "array set" C level code into a common routine ...
 check-in: 9aa06360d3 user: surles tags: core-8-1-branch-old
19:03
skip tests that require test* commands when running in standard tclsh interp. check-in: 1467d41628 user: hershey tags: core-8-1-branch-old
05:50
Updated for 8.1b3 check-in: 7fc5f3a9bd user: welch tags: core-8-1-branch-old
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to tests/encoding.test. 

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96

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

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

proc toutf {args} {
    global x
................................................................................
    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} {
    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 {}
    catch {unset encodings}







|







 







|








4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96

#
# 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.8 1999/04/06 19:03:56 hershey Exp $

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

proc toutf {args} {
    global x
................................................................................
    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} {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 {}
    catch {unset encodings}

Changes to tests/reg.test. 

3
4
5
6
7
8
9
10
11
12
13
14






15
16
17
18
19
20
21
...
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
...
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
...
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282

# 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
# test:  e for compile error expected, f for match failure expected, m
# for a successful match, and i for a successful match with -indices (used
# in checking things like nonparticipating subexpressions).  There is also
# a "doing" procedure which sets up title and major test number for each
................................................................................
		e [linsert $testid end ARE] ${f} $re $err
		e [linsert $testid end BRE] ${f}b $re $err
		return
	}

	set cmd [concat [list testregexp -$ask] [flags $flags] [list $re]]
	set run "list \[catch \{$cmd\}\] \[lindex \$errorCode 1\]"
	test $prefix.[tno $testid] [desc $testid] $run [list 1 REG_$err]
}

# match failure expected
proc f {testid flags re target args} {
	global prefix description ask

	# if &, test as both ARE and BRE
................................................................................
		# didn't tell us number of subexps
		set ccmd "lreplace \[$ccmd\] 0 0"
		set info [list $infoflags]
	} else {
		set info [list $nsub $infoflags]
	}
	lappend testid "compile"
	test $prefix.[tno $testid] [desc $testid] $ccmd $info

	set testid [lreplace $testid end end "execute"]
	set ecmd [concat [list testregexp] $f [list $re $target]]
	test $prefix.[tno $testid] [desc $testid] $ecmd 0
}

# match expected, internal routine that does the work
# parameters like the "real" routines except they don't have "opts",
#  which is a possibly-empty list of switches for the regexp match attempt
proc matchexpected {opts testid flags re target args} {
	global prefix description ask
................................................................................
	}
	set ecmd [concat $ecmd $names]
	set erun "list \[$ecmd\] $refs"
	set result [concat [list 1] $args]

	set info [list $nsub $infoflags]
	lappend testid "compile"
	test $prefix.[tno $testid] [desc $testid] $ccmd $info
	set testid [lreplace $testid end end "execute"]
	test $prefix.[tno $testid] [desc $testid] $erun $result
}

# match expected (no missing, empty, or ambiguous submatches)
# m testno flags re target mat submat ...
proc m {args} {
	eval matchexpected [linsert $args 0 [list]]
}







|




>
>
>
>
>
>







 







|







 







|



|







 







|

|








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
...
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
...
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
...
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288

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

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

# All tests require the testregexp command, return if this
# command doesn't exist

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

# This file uses some custom procedures, defined below, for regexp regression
# testing.  The name of the procedure indicates the general nature of the
# test:  e for compile error expected, f for match failure expected, m
# for a successful match, and i for a successful match with -indices (used
# in checking things like nonparticipating subexpressions).  There is also
# a "doing" procedure which sets up title and major test number for each
................................................................................
		e [linsert $testid end ARE] ${f} $re $err
		e [linsert $testid end BRE] ${f}b $re $err
		return
	}

	set cmd [concat [list testregexp -$ask] [flags $flags] [list $re]]
	set run "list \[catch \{$cmd\}\] \[lindex \$errorCode 1\]"
	test $prefix.[tno $testid] [desc $testid] {testregexp} $run [list 1 REG_$err]
}

# match failure expected
proc f {testid flags re target args} {
	global prefix description ask

	# if &, test as both ARE and BRE
................................................................................
		# didn't tell us number of subexps
		set ccmd "lreplace \[$ccmd\] 0 0"
		set info [list $infoflags]
	} else {
		set info [list $nsub $infoflags]
	}
	lappend testid "compile"
	test $prefix.[tno $testid] [desc $testid] {testregexp} $ccmd $info

	set testid [lreplace $testid end end "execute"]
	set ecmd [concat [list testregexp] $f [list $re $target]]
	test $prefix.[tno $testid] [desc $testid] {testregexp} $ecmd 0
}

# match expected, internal routine that does the work
# parameters like the "real" routines except they don't have "opts",
#  which is a possibly-empty list of switches for the regexp match attempt
proc matchexpected {opts testid flags re target args} {
	global prefix description ask
................................................................................
	}
	set ecmd [concat $ecmd $names]
	set erun "list \[$ecmd\] $refs"
	set result [concat [list 1] $args]

	set info [list $nsub $infoflags]
	lappend testid "compile"
	test $prefix.[tno $testid] [desc $testid] {testregexp} $ccmd $info
	set testid [lreplace $testid end end "execute"]
	test $prefix.[tno $testid] [desc $testid] {testregexp} $erun $result
}

# match expected (no missing, empty, or ambiguous submatches)
# m testno flags re target mat submat ...
proc m {args} {
	eval matchexpected [linsert $args 0 [list]]
}

Changes to tests/result.test. 

12
13
14
15
16
17
18





19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85

#
# SCCS: @(#) result.test 1.4 97/12/08 15:07:49

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






test result-1.1 {Tcl_SaveInterpResult} {
    testsaveresult small {set x 42} 0
} {small result}
test result-1.2 {Tcl_SaveInterpResult} {
    testsaveresult append {set x 42} 0
} {append result}
test result-1.3 {Tcl_SaveInterpResult} {
    testsaveresult dynamic {set x 42} 0
} {dynamic result notCalled present}
test result-1.4 {Tcl_SaveInterpResult} {
    testsaveresult object {set x 42} 0
} {object result same}
test result-1.5 {Tcl_SaveInterpResult} {
    testsaveresult small {set x 42} 1
} {42}
test result-1.6 {Tcl_SaveInterpResult} {
    testsaveresult append {set x 42} 1
} {42}
test result-1.7 {Tcl_SaveInterpResult} {
    testsaveresult dynamic {set x 42} 1
} {42 called missing}
test result-1.8 {Tcl_SaveInterpResult} {
    testsaveresult object {set x 42} 1
} {42 different}


# Tcl_RestoreInterpResult is mostly tested by the previous tests except
# for the following case

test result-2.1 {Tcl_RestoreInterpResult} {
    testsaveresult append {cd _foobar} 0
} {append result}

# Tcl_DiscardInterpResult is mostly tested by the previous tests except
# for the following cases

test result-3.1 {Tcl_DiscardInterpResult} {
    list [catch {testsaveresult append {cd _foobar} 1} msg] $msg
} {1 {couldn't change working directory to "_foobar": no such file or directory}}
test result-3.2 {Tcl_DiscardInterpResult} {
    testsaveresult free {set x 42} 1
} {42}

test result-4.1 {Tcl_SetObjErrorCode - one arg} {
    catch {testsetobjerrorcode 1}
    list [set errorCode]
} {1}
test result-4.2 {Tcl_SetObjErrorCode - two args} {
    catch {testsetobjerrorcode 1 2}
    list [set errorCode]
} {{1 2}}
test result-4.3 {Tcl_SetObjErrorCode - three args} {
    catch {testsetobjerrorcode 1 2 3}
    list [set errorCode]
} {{1 2 3}}
test result-4.4 {Tcl_SetObjErrorCode - four args} {
    catch {testsetobjerrorcode 1 2 3 4}
    list [set errorCode]
} {{1 2 3 4}}
test result-4.5 {Tcl_SetObjErrorCode - five args} {
    catch {testsetobjerrorcode 1 2 3 4 5}
    list [set errorCode]
} {{1 2 3 4 5}}

# cleanup
::tcltest::cleanupTests
return







>
>
>
>
>
|


|


|


|


|


|


|


|







|






|


|



|



|



|



|



|








12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90

#
# SCCS: @(#) result.test 1.4 97/12/08 15:07:49

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

# Some tests require the testsaveresult command

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

test result-1.1 {Tcl_SaveInterpResult} {testsaveresult} {
    testsaveresult small {set x 42} 0
} {small result}
test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} {
    testsaveresult append {set x 42} 0
} {append result}
test result-1.3 {Tcl_SaveInterpResult} {testsaveresult} {
    testsaveresult dynamic {set x 42} 0
} {dynamic result notCalled present}
test result-1.4 {Tcl_SaveInterpResult} {testsaveresult} {
    testsaveresult object {set x 42} 0
} {object result same}
test result-1.5 {Tcl_SaveInterpResult} {testsaveresult} {
    testsaveresult small {set x 42} 1
} {42}
test result-1.6 {Tcl_SaveInterpResult} {testsaveresult} {
    testsaveresult append {set x 42} 1
} {42}
test result-1.7 {Tcl_SaveInterpResult} {testsaveresult} {
    testsaveresult dynamic {set x 42} 1
} {42 called missing}
test result-1.8 {Tcl_SaveInterpResult} {testsaveresult} {
    testsaveresult object {set x 42} 1
} {42 different}


# Tcl_RestoreInterpResult is mostly tested by the previous tests except
# for the following case

test result-2.1 {Tcl_RestoreInterpResult} {testsaveresult} {
    testsaveresult append {cd _foobar} 0
} {append result}

# Tcl_DiscardInterpResult is mostly tested by the previous tests except
# for the following cases

test result-3.1 {Tcl_DiscardInterpResult} {testsaveresult} {
    list [catch {testsaveresult append {cd _foobar} 1} msg] $msg
} {1 {couldn't change working directory to "_foobar": no such file or directory}}
test result-3.2 {Tcl_DiscardInterpResult} {testsaveresult} {
    testsaveresult free {set x 42} 1
} {42}

test result-4.1 {Tcl_SetObjErrorCode - one arg} {testsaveresult} {
    catch {testsetobjerrorcode 1}
    list [set errorCode]
} {1}
test result-4.2 {Tcl_SetObjErrorCode - two args} {testsaveresult} {
    catch {testsetobjerrorcode 1 2}
    list [set errorCode]
} {{1 2}}
test result-4.3 {Tcl_SetObjErrorCode - three args} {testsaveresult} {
    catch {testsetobjerrorcode 1 2 3}
    list [set errorCode]
} {{1 2 3}}
test result-4.4 {Tcl_SetObjErrorCode - four args} {testsaveresult} {
    catch {testsetobjerrorcode 1 2 3 4}
    list [set errorCode]
} {{1 2 3 4}}
test result-4.5 {Tcl_SetObjErrorCode - five args} {testsaveresult} {
    catch {testsetobjerrorcode 1 2 3 4 5}
    list [set errorCode]
} {{1 2 3 4 5}}

# cleanup
::tcltest::cleanupTests
return

Changes to tests/utf.test. 

4
5
6
7
8
9
10
11
12
13
14
15


16
17
18
19
20
21
22

#
# 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
} [bytestring "\x01"]
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
    set x "\x00"
} [bytestring "\xc0\x80"]







|




>
>








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

#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: utf.test,v 1.1.2.7 1999/04/06 19:03:58 hershey Exp $

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

catch {unset x}

test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
    set x \x01
} [bytestring "\x01"]
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
    set x "\x00"
} [bytestring "\xc0\x80"]

This page was generated in about 0.021s by Fossil 2.9 [3a8abf492a] 2019-06-12 09:41:26