Tcl Source Code

Check-in [1467d41628]
Login
☰Core Home Timeline Branches Tags Tickets Download Wiki

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
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.000
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
Unified Diff Ignore Whitespace Patch
Changes to tests/encoding.test. 
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18

# This file contains a collection of tests for tclEncoding.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# 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











|








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18

# This file contains a collection of tests for tclEncoding.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# 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
︙︙
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96

    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}








|








82
83
84
85
86
87
88
89
90
91
92
93
94
95
96

    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. 
1
2
3
4
5
6
7
8
9
10
11
12
13
14






15
16
17
18
19
20
21

# reg.test --
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# 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










|




>
>
>
>
>
>








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

# reg.test --
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# 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
︙︙
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197

		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








|








189
190
191
192
193
194
195
196
197
198
199
200
201
202
203

		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
︙︙
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232

		# 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








|



|








220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238

		# 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
︙︙
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282

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








|

|








272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288

	}
	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. 
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15


16
17
18
19
20
21
22

# This file contains a collection of tests for tclUtf.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# 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"]











|




>
>








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

# This file contains a collection of tests for tclUtf.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# 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.03s by Fossil 2.26 [1205ec86cb] 2025-04-30 16:57:32