Tcl Source Code

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

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

Overview
Comment:
* tests/*.test: updated all tests to refer explicitly to the global variables ::errorInfo, ::errorCode, ::env and ::tcl_platform: many were relying on the alternative lookup in the global namespace, that feature is tested specifically in namespace and variable tests. The modified testfiles are: apply.test, basic.test, case.test, cmdIL.test, cmdMZ.test, compExpr-old.test, error.test, eval.test, event.test, expr.test, fileSystem.test, for.test, http.test, if.test, incr-old.test, incr.test, interp.test, io.test, ioCmd.test, load.test, misc.test, namespace.test, parse.test, parseOld.test, pkg.test, proc-old.test, set.test, switch.test, tcltest.test, thread.test, var.test, while-old.test, while.test.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk | tip-278-20061009
Files: files | file ages | folders
SHA1: a8fcd798f4d17d4d3c958b65f206e78267d99627
User & Date: msofer 2006-10-09 19:15:40
Context
2006-10-09
23:38
* doc/UpVar.3: brough the docs in accordance to the code. Ever since 8.0, Tcl_UpVar(2)? accepts TC...
check-in: 1eebdd2adf user: msofer tags: trunk
19:15
* tests/*.test: updated all tests to refer explicitly to the global variables ::errorInfo, ::error...
check-in: a8fcd798f4 user: msofer tags: trunk, tip-278-20061009
2006-10-06
14:14
bug #1571954: avoid /RTCc flag with MSVC8 check-in: 921a289f09 user: patthoyts tags: trunk, tip-278-branch-root
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.
















1
2
3
4
5
6
7














2006-10-06  Pat Thoyts  <[email protected]>

	* win/rules.vc: bug #1571954: avoid /RTCc flag with MSVC8

2006-10-06  Pat Thoyts  <[email protected]>

	* doc/binary.n:        TIP #275: Support unsigned values in
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
2006-10-09  Miguel Sofer  <[email protected]>

	* tests/*.test: updated all tests to refer explicitly to the
	global variables ::errorInfo, ::errorCode, ::env and
	::tcl_platform: many were relying on the alternative lookup in the
	global namespace, that feature is tested specifically in namespace
	and variable tests.
	The modified testfiles are: apply.test, basic.test, case.test,
	cmdIL.test, cmdMZ.test, compExpr-old.test, error.test, eval.test,
	event.test, expr.test, fileSystem.test, for.test, http.test,
	if.test, incr-old.test, incr.test, interp.test, io.test,
	ioCmd.test, load.test, misc.test, namespace.test, parse.test,
	parseOld.test, pkg.test, proc-old.test, set.test, switch.test,
	tcltest.test, thread.test, var.test, while-old.test, while.test.

2006-10-06  Pat Thoyts  <[email protected]>

	* win/rules.vc: bug #1571954: avoid /RTCc flag with MSVC8

2006-10-06  Pat Thoyts  <[email protected]>

	* doc/binary.n:        TIP #275: Support unsigned values in

Changes to tests/apply.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2005-2006 Miguel Sofer
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: apply.test,v 1.5 2006/03/10 19:49:14 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

if {[info commands ::apply] eq {}} {
................................................................................
    set res [catch {apply $lambda x y} msg]
    list $res $msg
} {1 {wrong # args: should be "apply {x {set x 1}} x"}}

test apply-5.1 {runtime error in lambda expression} {
    set lambda [list {} {error foo}]
    set res [catch {apply $lambda}]
    list $res $errorInfo
} {1 {foo
    while executing
"error foo"
    (procedure "apply {{} {error foo}}" line 1)
    invoked from within
"apply $lambda"}}







|







 







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2005-2006 Miguel Sofer
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: apply.test,v 1.6 2006/10/09 19:15:41 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

if {[info commands ::apply] eq {}} {
................................................................................
    set res [catch {apply $lambda x y} msg]
    list $res $msg
} {1 {wrong # args: should be "apply {x {set x 1}} x"}}

test apply-5.1 {runtime error in lambda expression} {
    set lambda [list {} {error foo}]
    set res [catch {apply $lambda}]
    list $res $::errorInfo
} {1 {foo
    while executing
"error foo"
    (procedure "apply {{} {error foo}}" line 1)
    invoked from within
"apply $lambda"}}

Changes to tests/basic.test.

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: basic.test,v 1.41 2006/01/18 19:48:11 dgp Exp $
#

package require tcltest 2
namespace import -force ::tcltest::*

testConstraint testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
................................................................................
test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} {
    catch {close $f}
    set res [catch {
	set f [open |[list [interpreter]] w+]
	fconfigure $f -buffering line
	puts $f {fconfigure stdout -buffering line}
	puts $f continue
	puts $f {puts $errorInfo}
	puts $f {puts DONE}
	set newMsg {}
	set msg {}
	while {$newMsg != "DONE"} {
	    set newMsg [gets $f]
	    append msg "${newMsg}\n"
	}






|







 







|







11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: basic.test,v 1.42 2006/10/09 19:15:44 msofer Exp $
#

package require tcltest 2
namespace import -force ::tcltest::*

testConstraint testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
................................................................................
test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} {
    catch {close $f}
    set res [catch {
	set f [open |[list [interpreter]] w+]
	fconfigure $f -buffering line
	puts $f {fconfigure stdout -buffering line}
	puts $f continue
	puts $f {puts $::errorInfo}
	puts $f {puts DONE}
	set newMsg {}
	set msg {}
	while {$newMsg != "DONE"} {
	    set newMsg [gets $f]
	    append msg "${newMsg}\n"
	}

Changes to tests/case.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
..
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: case.test,v 1.6 2004/05/19 10:52:35 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test case-1.1 {simple pattern} {
................................................................................
} 3
test case-1.7 {list of patterns} {
    case abc in {a b c} {format 1} {def abc ghi} {format 2}
} 2

test case-2.1 {error in executed command} {
    list [catch {case a in a {error "Just a test"} default {format 1}} msg] \
	    $msg $errorInfo
} {1 {Just a test} {Just a test
    while executing
"error "Just a test""
    ("a" arm line 1)
    invoked from within
"case a in a {error "Just a test"} default {format 1}"}}
test case-2.2 {error: not enough args} {
................................................................................
    list [catch {case a b} msg] $msg
} {1 {extra case pattern with no body}}
test case-2.4 {error: pattern with no body} {
    list [catch {case a in b {format 1} c} msg] $msg
} {1 {extra case pattern with no body}}
test case-2.5 {error in default command} {
    list [catch {case foo in a {error case1} default {error case2} \
	    b {error case 3}} msg] $msg $errorInfo
} {1 case2 {case2
    while executing
"error case2"
    ("default" arm line 1)
    invoked from within
"case foo in a {error case1} default {error case2}  b {error case 3}"}}







|







 







|







 







|







7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
..
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: case.test,v 1.7 2006/10/09 19:15:44 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test case-1.1 {simple pattern} {
................................................................................
} 3
test case-1.7 {list of patterns} {
    case abc in {a b c} {format 1} {def abc ghi} {format 2}
} 2

test case-2.1 {error in executed command} {
    list [catch {case a in a {error "Just a test"} default {format 1}} msg] \
	    $msg $::errorInfo
} {1 {Just a test} {Just a test
    while executing
"error "Just a test""
    ("a" arm line 1)
    invoked from within
"case a in a {error "Just a test"} default {format 1}"}}
test case-2.2 {error: not enough args} {
................................................................................
    list [catch {case a b} msg] $msg
} {1 {extra case pattern with no body}}
test case-2.4 {error: pattern with no body} {
    list [catch {case a in b {format 1} c} msg] $msg
} {1 {extra case pattern with no body}}
test case-2.5 {error in default command} {
    list [catch {case foo in a {error case1} default {error case2} \
	    b {error case 3}} msg] $msg $::errorInfo
} {1 case2 {case2
    while executing
"error case2"
    ("default" arm line 1)
    invoked from within
"case foo in a {error case1} default {error case2}  b {error case 3}"}}

Changes to tests/cmdIL.test.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdIL.test,v 1.27 2006/08/09 14:16:03 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Used for constraining memory leak tests
................................................................................
test cmdIL-3.14 {SortCompare procedure, -real option} {
    lsort -real {24 2.5e01 16.7 85e-1 10.004}
} {85e-1 10.004 16.7 24 2.5e01}
test cmdIL-3.15 {SortCompare procedure, -command option} -body {
    proc cmp {a b} {
	error "comparison error"
    }
    list [catch {lsort -command cmp {48 6}} msg] $msg $errorInfo
} -cleanup {
    rename cmp ""
} -result {1 {comparison error} {comparison error
    while executing
"error "comparison error""
    (procedure "cmp" line 2)
    invoked from within






|







 







|







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdIL.test,v 1.28 2006/10/09 19:15:44 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Used for constraining memory leak tests
................................................................................
test cmdIL-3.14 {SortCompare procedure, -real option} {
    lsort -real {24 2.5e01 16.7 85e-1 10.004}
} {85e-1 10.004 16.7 24 2.5e01}
test cmdIL-3.15 {SortCompare procedure, -command option} -body {
    proc cmp {a b} {
	error "comparison error"
    }
    list [catch {lsort -command cmp {48 6}} msg] $msg $::errorInfo
} -cleanup {
    rename cmp ""
} -result {1 {comparison error} {comparison error
    while executing
"error "comparison error""
    (procedure "cmp" line 2)
    invoked from within

Changes to tests/cmdMZ.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
...
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
...
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdMZ.test,v 1.24 2004/07/06 21:08:37 dgp Exp $

if {[catch {package require tcltest 2.1}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
    return
}

namespace eval ::tcl::test::cmdMZ {
................................................................................
} {1 {error getting working directory name: permission denied}}

# The tests for Tcl_RegexpObjCmd, Tcl_RegsubObjCmd are in regexp.test

# Tcl_RenameObjCmd

test cmdMZ-2.1 {Tcl_RenameObjCmd: error conditions} {
    list [catch {rename r1} msg] $msg $errorCode
} {1 {wrong # args: should be "rename oldName newName"} NONE}
test cmdMZ-2.2 {Tcl_RenameObjCmd: error conditions} {
    list [catch {rename r1 r2 r3} msg] $msg $errorCode
} {1 {wrong # args: should be "rename oldName newName"} NONE}
test cmdMZ-2.3 {Tcl_RenameObjCmd: success} {
    catch {rename r2 {}}
    proc r1 {} {return "r1"}
    rename r1 r2
    r2
} {r1}
................................................................................

test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body {
    set file [makeFile {
	set x 146
	error "error in sourced file"
	set y $x
    } source.file]
    set result [list [catch {source $file} msg] $msg $errorInfo]
    removeFile source.file
    set result
} -match listGlob -result {1 {error in sourced file} {error in sourced file
    while executing
"error "error in sourced file""
    (file "*" line 3)
    invoked from within
................................................................................
    removeFile source.file
    set result
} result

# Tcl_SplitObjCmd

test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} {
    list [catch split msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
test cmdMZ-4.2 {Tcl_SplitObjCmd: split errors} {
    list [catch {split a b c} msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
test cmdMZ-4.3 {Tcl_SplitObjCmd: basic split commands} {
    split "a\n b\t\r c\n "
} {a {} b {} {} c {} {}}
test cmdMZ-4.4 {Tcl_SplitObjCmd: basic split commands} {
    split "word 1xyzword 2zword 3" xyz
} {{word 1} {} {} {word 2} {word 3}}






|







 







|


|







 







|







 







|


|







7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
...
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
...
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdMZ.test,v 1.25 2006/10/09 19:15:44 msofer Exp $

if {[catch {package require tcltest 2.1}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
    return
}

namespace eval ::tcl::test::cmdMZ {
................................................................................
} {1 {error getting working directory name: permission denied}}

# The tests for Tcl_RegexpObjCmd, Tcl_RegsubObjCmd are in regexp.test

# Tcl_RenameObjCmd

test cmdMZ-2.1 {Tcl_RenameObjCmd: error conditions} {
    list [catch {rename r1} msg] $msg $::errorCode
} {1 {wrong # args: should be "rename oldName newName"} NONE}
test cmdMZ-2.2 {Tcl_RenameObjCmd: error conditions} {
    list [catch {rename r1 r2 r3} msg] $msg $::errorCode
} {1 {wrong # args: should be "rename oldName newName"} NONE}
test cmdMZ-2.3 {Tcl_RenameObjCmd: success} {
    catch {rename r2 {}}
    proc r1 {} {return "r1"}
    rename r1 r2
    r2
} {r1}
................................................................................

test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body {
    set file [makeFile {
	set x 146
	error "error in sourced file"
	set y $x
    } source.file]
    set result [list [catch {source $file} msg] $msg $::errorInfo]
    removeFile source.file
    set result
} -match listGlob -result {1 {error in sourced file} {error in sourced file
    while executing
"error "error in sourced file""
    (file "*" line 3)
    invoked from within
................................................................................
    removeFile source.file
    set result
} result

# Tcl_SplitObjCmd

test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} {
    list [catch split msg] $msg $::errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
test cmdMZ-4.2 {Tcl_SplitObjCmd: split errors} {
    list [catch {split a b c} msg] $msg $::errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
test cmdMZ-4.3 {Tcl_SplitObjCmd: basic split commands} {
    split "a\n b\t\r c\n "
} {a {} b {} {} c {} {}}
test cmdMZ-4.4 {Tcl_SplitObjCmd: basic split commands} {
    split "word 1xyzword 2zword 3" xyz
} {{word 1} {} {} {word 2} {word 3}}

Changes to tests/compExpr-old.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
...
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
...
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: compExpr-old.test,v 1.20 2006/08/22 04:03:23 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
................................................................................
    set msg
} {wrong # args: should be "set varName ?newValue?"}
test compExpr-old-14.22 {CompilePrimaryExpr: subcommand primary} {
    expr {[set i 123; set i]}
} 123
test compExpr-old-14.23 {CompilePrimaryExpr: error in subcommand primary} -body {
    catch {expr {[set]}} msg
    set errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
test compExpr-old-14.24 {CompilePrimaryExpr: error in subcommand primary} -body {
    expr {[set i}
} -returnCodes error -match glob -result *
test compExpr-old-14.25 {CompilePrimaryExpr: math function primary} {
................................................................................
    expr sinh::(2.0)
} -returnCodes error -match glob -result *
test compExpr-old-14.28 {CompilePrimaryExpr: subexpression primary} {
    expr 2+(3*4)
} 14
test compExpr-old-14.29 {CompilePrimaryExpr: error in subexpression primary} -body {
    catch {expr 2+(3*[set])} msg
    set errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
test compExpr-old-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} -body {
    expr 2+(3*(4+5)
} -returnCodes error -match glob -result *
test compExpr-old-14.31 {CompilePrimaryExpr: just var ref in subexpression primary} {
................................................................................
} -returnCodes error -match glob -result *

test compExpr-old-15.1 {CompileMathFuncCall: missing parenthesis} -body {
    expr sinh2.0)
} -returnCodes error -match glob -result *
test compExpr-old-15.2 {CompileMathFuncCall: unknown math function} -body {
    catch {expr whazzathuh(1)} msg
    set errorInfo
} -match glob -result {* "*whazzathuh"
    while *ing
"expr whazzathuh(1)"}
test compExpr-old-15.3 {CompileMathFuncCall: too many arguments} -body {
    catch {expr sin(1,2,3)} msg
    set errorInfo
} -match glob -result {too many arguments for math function*
    while *ing
"expr sin(1,2,3)"}
test compExpr-old-15.4 {CompileMathFuncCall: ')' found before last required arg} -body {
    catch {expr sin()} msg
    set errorInfo
} -match glob -result {too few arguments for math function*
    while *ing
"expr sin()"}
test compExpr-old-15.5 {CompileMathFuncCall: too few arguments} -body {
    catch {expr pow(1)} msg
    set errorInfo
} -match glob -result {too few arguments for math function*
    while *ing
"expr pow(1)"}
test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body {
    expr sin(1
} -returnCodes error -match glob -result *
test compExpr-old-15.7 {CompileMathFuncCall: call registered math function} testmathfunctions {






|







 







|







 







|







 







|





|





|





|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
...
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
...
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: compExpr-old.test,v 1.21 2006/10/09 19:15:44 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
................................................................................
    set msg
} {wrong # args: should be "set varName ?newValue?"}
test compExpr-old-14.22 {CompilePrimaryExpr: subcommand primary} {
    expr {[set i 123; set i]}
} 123
test compExpr-old-14.23 {CompilePrimaryExpr: error in subcommand primary} -body {
    catch {expr {[set]}} msg
    set ::errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
test compExpr-old-14.24 {CompilePrimaryExpr: error in subcommand primary} -body {
    expr {[set i}
} -returnCodes error -match glob -result *
test compExpr-old-14.25 {CompilePrimaryExpr: math function primary} {
................................................................................
    expr sinh::(2.0)
} -returnCodes error -match glob -result *
test compExpr-old-14.28 {CompilePrimaryExpr: subexpression primary} {
    expr 2+(3*4)
} 14
test compExpr-old-14.29 {CompilePrimaryExpr: error in subexpression primary} -body {
    catch {expr 2+(3*[set])} msg
    set ::errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
test compExpr-old-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} -body {
    expr 2+(3*(4+5)
} -returnCodes error -match glob -result *
test compExpr-old-14.31 {CompilePrimaryExpr: just var ref in subexpression primary} {
................................................................................
} -returnCodes error -match glob -result *

test compExpr-old-15.1 {CompileMathFuncCall: missing parenthesis} -body {
    expr sinh2.0)
} -returnCodes error -match glob -result *
test compExpr-old-15.2 {CompileMathFuncCall: unknown math function} -body {
    catch {expr whazzathuh(1)} msg
    set ::errorInfo
} -match glob -result {* "*whazzathuh"
    while *ing
"expr whazzathuh(1)"}
test compExpr-old-15.3 {CompileMathFuncCall: too many arguments} -body {
    catch {expr sin(1,2,3)} msg
    set ::errorInfo
} -match glob -result {too many arguments for math function*
    while *ing
"expr sin(1,2,3)"}
test compExpr-old-15.4 {CompileMathFuncCall: ')' found before last required arg} -body {
    catch {expr sin()} msg
    set ::errorInfo
} -match glob -result {too few arguments for math function*
    while *ing
"expr sin()"}
test compExpr-old-15.5 {CompileMathFuncCall: too few arguments} -body {
    catch {expr pow(1)} msg
    set ::errorInfo
} -match glob -result {too few arguments for math function*
    while *ing
"expr pow(1)"}
test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body {
    expr sin(1
} -returnCodes error -match glob -result *
test compExpr-old-15.7 {CompileMathFuncCall: call registered math function} testmathfunctions {

Changes to tests/error.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
..
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
...
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
...
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
...
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: error.test,v 1.15 2006/01/18 19:48:11 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

namespace eval ::tcl::test::error {
................................................................................
test error-1.2 {simple errors from commands} {
    catch {format [string index]} b
    set b
} {wrong # args: should be "string index string charIndex"}

test error-1.3 {simple errors from commands} {
    catch {format [string index]} b
    set errorInfo
    # this used to return '... while executing ...', but
    # string index is fully compiled as of 8.4a3
} {wrong # args: should be "string index string charIndex"
    while executing
"string index"}

test error-1.4 {simple errors from commands} {
................................................................................
test error-2.2 {errors in nested procedures} {
    catch foo b
    set b
} {Human-generated}

test error-2.3 {errors in nested procedures} {
    catch foo b
    set errorInfo
} {Human-generated
    while executing
"error {Human-generated}"
    (procedure "foo" line 4)
    invoked from within
"foo"}

................................................................................
test error-2.5 {errors in nested procedures} {
    catch foo2 b
    set b
} {Human-generated}

test error-2.6 {errors in nested procedures} {
    catch foo2 b
    set errorInfo
} {glorp2
    while executing
"error glorp2"
    (procedure "foo2" line 3)
    invoked from within
"foo2"}

................................................................................
    list [catch {catch {format 44} a} msg] $msg
} {1 {couldn't save command result in variable}}
catch {unset a}

# More tests related to errorInfo and errorCode

test error-4.1 {errorInfo and errorCode variables} {
    list [catch {error msg1 msg2 msg3} msg] $msg $errorInfo $errorCode
} {1 msg1 msg2 msg3}
test error-4.2 {errorInfo and errorCode variables} {
    list [catch {error msg1 {} msg3} msg] $msg $errorInfo $errorCode
} {1 msg1 {msg1
    while executing
"error msg1 {} msg3"} msg3}
test error-4.3 {errorInfo and errorCode variables} {
    list [catch {error msg1 {}} msg] $msg $errorInfo $errorCode
} {1 msg1 {msg1
    while executing
"error msg1 {}"} NONE}
test error-4.4 {errorInfo and errorCode variables} {
    set errorCode bogus
    list [catch {error msg1} msg] $msg $errorInfo $errorCode
} {1 msg1 {msg1
    while executing
"error msg1"} NONE}
test error-4.5 {errorInfo and errorCode variables} {
    set errorCode bogus
    list [catch {error msg1 msg2 {}} msg] $msg $errorInfo $errorCode
} {1 msg1 msg2 {}}

# Errors in error command itself

test error-5.1 {errors in error command} {
    list [catch {error} msg] $msg
} {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}}
................................................................................
    list [catch {error a b c d} msg] $msg
} {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}}

# Make sure that catch resets error information

test error-6.1 {catch must reset error state} {
    catch {error outer [catch {error inner inner.errorInfo inner.errorCode}]}
    list $errorCode $errorInfo
} {NONE 1}
test error-6.2 {catch must reset error state} {
    catch {error outer [catch {return -level 0 -code error -errorcode BUG}]}
    list $errorCode $errorInfo
} {NONE 1}
test error-6.3 {catch must reset error state} {
    set errorCode BUG
    catch {error outer [catch set]}
    list $errorCode $errorInfo
} {NONE 1}
test error-6.4 {catch must reset error state} {
    catch {error [catch {error foo bar baz}] 1}
    list $errorCode $errorInfo
} {NONE 1}
test error-6.5 {catch must reset error state} {
    catch {error [catch {return -level 0 -code error -errorcode BUG}] 1}
    list $errorCode $errorInfo
} {NONE 1}
test error-6.6 {catch must reset error state} {
    catch {return -level 0 -code error -errorinfo [catch {error foo bar baz}]}
    list $errorCode $errorInfo
} {NONE 1}
test error-6.7 {catch must reset error state} {
    proc foo {} {
	return -code error -errorinfo [catch {error foo bar baz}]
    }
    catch foo
    list $errorCode
} {NONE}
test error-6.8 {catch must reset error state} {
    catch {return -level 0 -code error [catch {error foo bar baz}]}
    list $errorCode
} {NONE}
test error-6.9 {catch must reset error state} {
    proc foo {} {
	return -code error [catch {error foo bar baz}]
    }
    catch foo
    list $errorCode
} {NONE}

    test error-7.0 {Bug 1397843} -body {
	variable cmds
	proc EIWrite args {
	    variable cmds
	    lappend cmds [lindex [info level -2] 0]






|







 







|







 







|







 







|







 







|


|




|




|
|




|
|







 







|



|


|

|



|



|



|






|



|






|







7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
..
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
...
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
...
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
...
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: error.test,v 1.16 2006/10/09 19:15:44 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

namespace eval ::tcl::test::error {
................................................................................
test error-1.2 {simple errors from commands} {
    catch {format [string index]} b
    set b
} {wrong # args: should be "string index string charIndex"}

test error-1.3 {simple errors from commands} {
    catch {format [string index]} b
    set ::errorInfo
    # this used to return '... while executing ...', but
    # string index is fully compiled as of 8.4a3
} {wrong # args: should be "string index string charIndex"
    while executing
"string index"}

test error-1.4 {simple errors from commands} {
................................................................................
test error-2.2 {errors in nested procedures} {
    catch foo b
    set b
} {Human-generated}

test error-2.3 {errors in nested procedures} {
    catch foo b
    set ::errorInfo
} {Human-generated
    while executing
"error {Human-generated}"
    (procedure "foo" line 4)
    invoked from within
"foo"}

................................................................................
test error-2.5 {errors in nested procedures} {
    catch foo2 b
    set b
} {Human-generated}

test error-2.6 {errors in nested procedures} {
    catch foo2 b
    set ::errorInfo
} {glorp2
    while executing
"error glorp2"
    (procedure "foo2" line 3)
    invoked from within
"foo2"}

................................................................................
    list [catch {catch {format 44} a} msg] $msg
} {1 {couldn't save command result in variable}}
catch {unset a}

# More tests related to errorInfo and errorCode

test error-4.1 {errorInfo and errorCode variables} {
    list [catch {error msg1 msg2 msg3} msg] $msg $::errorInfo $::errorCode
} {1 msg1 msg2 msg3}
test error-4.2 {errorInfo and errorCode variables} {
    list [catch {error msg1 {} msg3} msg] $msg $::errorInfo $::errorCode
} {1 msg1 {msg1
    while executing
"error msg1 {} msg3"} msg3}
test error-4.3 {errorInfo and errorCode variables} {
    list [catch {error msg1 {}} msg] $msg $::errorInfo $::errorCode
} {1 msg1 {msg1
    while executing
"error msg1 {}"} NONE}
test error-4.4 {errorInfo and errorCode variables} {
    set ::errorCode bogus
    list [catch {error msg1} msg] $msg $::errorInfo $::errorCode
} {1 msg1 {msg1
    while executing
"error msg1"} NONE}
test error-4.5 {errorInfo and errorCode variables} {
    set ::errorCode bogus
    list [catch {error msg1 msg2 {}} msg] $msg $::errorInfo $::errorCode
} {1 msg1 msg2 {}}

# Errors in error command itself

test error-5.1 {errors in error command} {
    list [catch {error} msg] $msg
} {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}}
................................................................................
    list [catch {error a b c d} msg] $msg
} {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}}

# Make sure that catch resets error information

test error-6.1 {catch must reset error state} {
    catch {error outer [catch {error inner inner.errorInfo inner.errorCode}]}
    list $::errorCode $::errorInfo
} {NONE 1}
test error-6.2 {catch must reset error state} {
    catch {error outer [catch {return -level 0 -code error -errorcode BUG}]}
    list $::errorCode $::errorInfo
} {NONE 1}
test error-6.3 {catch must reset error state} {
    set ::errorCode BUG
    catch {error outer [catch set]}
    list $::errorCode $::errorInfo
} {NONE 1}
test error-6.4 {catch must reset error state} {
    catch {error [catch {error foo bar baz}] 1}
    list $::errorCode $::errorInfo
} {NONE 1}
test error-6.5 {catch must reset error state} {
    catch {error [catch {return -level 0 -code error -errorcode BUG}] 1}
    list $::errorCode $::errorInfo
} {NONE 1}
test error-6.6 {catch must reset error state} {
    catch {return -level 0 -code error -errorinfo [catch {error foo bar baz}]}
    list $::errorCode $::errorInfo
} {NONE 1}
test error-6.7 {catch must reset error state} {
    proc foo {} {
	return -code error -errorinfo [catch {error foo bar baz}]
    }
    catch foo
    list $::errorCode
} {NONE}
test error-6.8 {catch must reset error state} {
    catch {return -level 0 -code error [catch {error foo bar baz}]}
    list $::errorCode
} {NONE}
test error-6.9 {catch must reset error state} {
    proc foo {} {
	return -code error [catch {error foo bar baz}]
    }
    catch foo
    list $::errorCode
} {NONE}

    test error-7.0 {Bug 1397843} -body {
	variable cmds
	proc EIWrite args {
	    variable cmds
	    lappend cmds [lindex [info level -2] 0]

Changes to tests/eval.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: eval.test,v 1.8 2006/01/18 19:48:11 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test eval-1.1 {single argument} {
................................................................................
    set msg
} {test error}
test eval-2.5 {error in eval'ed command: setting errorInfo} {
    catch {eval {
	set a 1
	error "test error"
    }} msg
    set errorInfo
} "test error
    while executing
\"error \"test error\"\"
    (\"eval\" body line 3)
    invoked from within
\"eval {
	set a 1






|







 







|







7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: eval.test,v 1.9 2006/10/09 19:15:44 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test eval-1.1 {single argument} {
................................................................................
    set msg
} {test error}
test eval-2.5 {error in eval'ed command: setting errorInfo} {
    catch {eval {
	set a 1
	error "test error"
    }} msg
    set ::errorInfo
} "test error
    while executing
\"error \"test error\"\"
    (\"eval\" body line 3)
    invoked from within
\"eval {
	set a 1

Changes to tests/event.test.

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
#
# 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.20 2002/07/10 11:56:44 dgp Exp $

package require tcltest 2
namespace import -force ::tcltest::*

testConstraint testfilehandler [llength [info commands testfilehandler]]
testConstraint testexithandler [llength [info commands testexithandler]]
testConstraint testfilewait [llength [info commands testfilewait]]
................................................................................
    set result
} {even 16
}

test event-10.1 {Tcl_Exit procedure} {stdio} {
    set child [open |[list [interpreter]] r+]
    puts $child "exit 3"
    list [catch {close $child} msg] $msg [lindex $errorCode 0] \
        [lindex $errorCode 2]
} {1 {child process exited abnormally} CHILDSTATUS 3}

test event-11.1 {Tcl_VwaitCmd procedure} {
    list [catch {vwait} msg] $msg
} {1 {wrong # args: should be "vwait name"}}
test event-11.2 {Tcl_VwaitCmd procedure} {
    list [catch {vwait a b} msg] $msg






|







 







|
|







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
#
# 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.21 2006/10/09 19:15:44 msofer Exp $

package require tcltest 2
namespace import -force ::tcltest::*

testConstraint testfilehandler [llength [info commands testfilehandler]]
testConstraint testexithandler [llength [info commands testexithandler]]
testConstraint testfilewait [llength [info commands testfilewait]]
................................................................................
    set result
} {even 16
}

test event-10.1 {Tcl_Exit procedure} {stdio} {
    set child [open |[list [interpreter]] r+]
    puts $child "exit 3"
    list [catch {close $child} msg] $msg [lindex $::errorCode 0] \
        [lindex $::errorCode 2]
} {1 {child process exited abnormally} CHILDSTATUS 3}

test event-11.1 {Tcl_VwaitCmd procedure} {
    list [catch {vwait} msg] $msg
} {1 {wrong # args: should be "vwait name"}}
test event-11.2 {Tcl_VwaitCmd procedure} {
    list [catch {vwait a b} msg] $msg

Changes to tests/expr.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
...
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
...
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: expr.test,v 1.62 2006/09/28 20:06:43 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.1
    namespace import -force ::tcltest::*
}

testConstraint testmathfunctions [expr {
................................................................................
    set msg
} {wrong # args: should be "set varName ?newValue?"}
test expr-14.22 {CompilePrimaryExpr: subcommand primary} {
    expr {[set i 123; set i]}
} 123
test expr-14.23 {CompilePrimaryExpr: error in subcommand primary} -body {
    catch {expr {[set]}} msg
    set errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
test expr-14.24 {CompilePrimaryExpr: error in subcommand primary} -body {
    expr {[set i}
} -returnCodes error -match glob -result *
test expr-14.25 {CompilePrimaryExpr: math function primary} {
................................................................................
    expr sinh::(2.0)
} -returnCodes error -match glob -result *
test expr-14.28 {CompilePrimaryExpr: subexpression primary} {
    expr 2+(3*4)
} 14
test expr-14.29 {CompilePrimaryExpr: error in subexpression primary} -body {
    catch {expr 2+(3*[set])} msg
    set errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
test expr-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} -body {
    expr 2+(3*(4+5)
} -returnCodes error -match glob -result *
test expr-14.31 {CompilePrimaryExpr: just var ref in subexpression primary} {
................................................................................
} -returnCodes error -match glob -result *

test expr-15.1 {CompileMathFuncCall: missing parenthesis} -body {
    expr sinh2.0)
} -returnCodes error -match glob -result *
test expr-15.2 {CompileMathFuncCall: unknown math function} -body {
    catch {expr whazzathuh(1)} msg
    set errorInfo
} -match glob -result {* "*whazzathuh"
    while *ing
"expr whazzathuh(1)"}
test expr-15.3 {CompileMathFuncCall: too many arguments} -body {
    catch {expr sin(1,2,3)} msg
    set errorInfo
} -match glob -result {too many arguments for math function*
    while *ing
"expr sin(1,2,3)"}
test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} -body {
    catch {expr sin()} msg
    set errorInfo
} -match glob -result {too few arguments for math function*
    while *ing
"expr sin()"}
test expr-15.5 {CompileMathFuncCall: too few arguments} -body {
    catch {expr pow(1)} msg
    set errorInfo
} -match glob -result {too few arguments for math function*
    while *ing
"expr pow(1)"}
test expr-15.6 {CompileMathFuncCall: missing ')'} -body {
    expr sin(1
} -returnCodes error -match glob -result *
test expr-15.7 {CompileMathFuncCall: call registered math function} {testmathfunctions} {






|







 







|







 







|







 







|





|





|





|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
...
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
...
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: expr.test,v 1.63 2006/10/09 19:15:44 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.1
    namespace import -force ::tcltest::*
}

testConstraint testmathfunctions [expr {
................................................................................
    set msg
} {wrong # args: should be "set varName ?newValue?"}
test expr-14.22 {CompilePrimaryExpr: subcommand primary} {
    expr {[set i 123; set i]}
} 123
test expr-14.23 {CompilePrimaryExpr: error in subcommand primary} -body {
    catch {expr {[set]}} msg
    set ::errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
test expr-14.24 {CompilePrimaryExpr: error in subcommand primary} -body {
    expr {[set i}
} -returnCodes error -match glob -result *
test expr-14.25 {CompilePrimaryExpr: math function primary} {
................................................................................
    expr sinh::(2.0)
} -returnCodes error -match glob -result *
test expr-14.28 {CompilePrimaryExpr: subexpression primary} {
    expr 2+(3*4)
} 14
test expr-14.29 {CompilePrimaryExpr: error in subexpression primary} -body {
    catch {expr 2+(3*[set])} msg
    set ::errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
test expr-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} -body {
    expr 2+(3*(4+5)
} -returnCodes error -match glob -result *
test expr-14.31 {CompilePrimaryExpr: just var ref in subexpression primary} {
................................................................................
} -returnCodes error -match glob -result *

test expr-15.1 {CompileMathFuncCall: missing parenthesis} -body {
    expr sinh2.0)
} -returnCodes error -match glob -result *
test expr-15.2 {CompileMathFuncCall: unknown math function} -body {
    catch {expr whazzathuh(1)} msg
    set ::errorInfo
} -match glob -result {* "*whazzathuh"
    while *ing
"expr whazzathuh(1)"}
test expr-15.3 {CompileMathFuncCall: too many arguments} -body {
    catch {expr sin(1,2,3)} msg
    set ::errorInfo
} -match glob -result {too many arguments for math function*
    while *ing
"expr sin(1,2,3)"}
test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} -body {
    catch {expr sin()} msg
    set ::errorInfo
} -match glob -result {too few arguments for math function*
    while *ing
"expr sin()"}
test expr-15.5 {CompileMathFuncCall: too few arguments} -body {
    catch {expr pow(1)} msg
    set ::errorInfo
} -match glob -result {too few arguments for math function*
    while *ing
"expr pow(1)"}
test expr-15.6 {CompileMathFuncCall: missing ')'} -body {
    expr sin(1
} -returnCodes error -match glob -result *
test expr-15.7 {CompileMathFuncCall: call registered math function} {testmathfunctions} {

Changes to tests/fileSystem.test.

580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
    -result {*{matchindirectory *}*}
}

test filesystem-5.1 {cache and ~} {
    -constraints testfilesystem
    -match regexp
    -body {
	set orig $env(HOME)
	set ::env(HOME) /foo/bar/blah
	set testdir ~
	set res1 "Parent of ~ (/foo/bar/blah) is [file dirname $testdir]"
	set ::env(HOME) /a/b/c
	set res2 "Parent of ~ (/a/b/c) is [file dirname $testdir]"
	set ::env(HOME) $orig
	list $res1 $res2






|







580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
    -result {*{matchindirectory *}*}
}

test filesystem-5.1 {cache and ~} {
    -constraints testfilesystem
    -match regexp
    -body {
	set orig $::env(HOME)
	set ::env(HOME) /foo/bar/blah
	set testdir ~
	set res1 "Parent of ~ (/foo/bar/blah) is [file dirname $testdir]"
	set ::env(HOME) /a/b/c
	set res2 "Parent of ~ (/a/b/c) is [file dirname $testdir]"
	set ::env(HOME) $orig
	list $res1 $res2

Changes to tests/for.test.

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
..
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
..
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
...
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
...
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for.test,v 1.15 2006/08/22 18:10:43 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Basic "for" operation.

test for-1.1 {TclCompileForCmd: missing initial command} {
    list [catch {for} msg] $msg
} {1 {wrong # args: should be "for start test next command"}}
test for-1.2 {TclCompileForCmd: error in initial command} -body {
    list [catch {for {set}} msg] $msg $errorInfo
} -match glob -result {1 {wrong # args: should be "for start test next command"} {wrong # args: should be "for start test next command"
    while *ing
"for {set}"}}
catch {unset i}
test for-1.3 {TclCompileForCmd: missing test expression} {
    catch {for {set i 0}} msg
    set msg
} {wrong # args: should be "for start test next command"}
test for-1.4 {TclCompileForCmd: error in test expression} -body {
    catch {for {set i 0} {$i<}} msg
    set errorInfo
} -match glob -result {wrong # args: should be "for start test next command"
    while *ing
"for {set i 0} {$i<}"}
test for-1.5 {TclCompileForCmd: test expression is enclosed in quotes} {
    set i 0
    for {} "$i > 5" {incr i} {}
} {}
................................................................................
} {wrong # args: should be "for start test next command"}
test for-1.7 {TclCompileForCmd: missing command body} {
    catch {for {set i 0} {$i < 5} {incr i}} msg
    set msg
} {wrong # args: should be "for start test next command"}
test for-1.8 {TclCompileForCmd: error compiling command body} -body {
    catch {for {set i 0} {$i < 5} {incr i} {set}} msg
    set errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
catch {unset a}
test for-1.9 {TclCompileForCmd: simple command body} {
    set a {}
    for {set i 1} {$i<6} {set i [expr $i+1]} {
................................................................................
    set x2 {; append a x2}
    set a {}
    for {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2
    set a
} {x1}
test for-1.12 {TclCompileForCmd: error in "next" command} -body {
    catch {for {set i 0} {$i < 5} {set} {format $i}} msg
    set errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
test for-1.13 {TclCompileForCmd: long command body} {
    set a {}
    for {set i 1} {$i<6} {set i [expr $i+1]} {
	if $i==4 break
................................................................................
test for-6.5 {Tcl_ForObjCmd: number of args} {
    set z for
    catch {$z {set i 0} {$i < 5} {incr i} {body} extra} msg
    set msg
} {wrong # args: should be "for start test next command"}
test for-6.6 {Tcl_ForObjCmd: error in initial command} -body {
    set z for
    list [catch {$z {set} {$i < 5} {incr i} {body}} msg] $msg $errorInfo
} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"
    ("for" initial command)
    invoked from within
"$z {set} {$i < 5} {incr i} {body}"}}
test for-6.7 {Tcl_ForObjCmd: error in test expression} -body {
    set z for
    catch {$z {set i 0} {i < 5} {incr i} {body}}
    set errorInfo
} -match glob -result {*"$z {set i 0} {i < 5} {incr i} {body}"}
test for-6.8 {Tcl_ForObjCmd: test expression is enclosed in quotes} {
    set z for
    set i 0
    $z {set i 6} "$i > 5" {incr i} {set y $i}
    set i
} 6
test for-6.9 {Tcl_ForObjCmd: error executing command body} -body {
    set z for
    catch {$z {set i 0} {$i < 5} {incr i} {set}} msg
    set errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"
    ("for" body line 1)
    invoked from within
"$z {set i 0} {$i < 5} {incr i} {set}"}
test for-6.10 {Tcl_ForObjCmd: simple command body} {
................................................................................
    set a {}
    $z {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2
    set a
} {x1}
test for-6.13 {Tcl_ForObjCmd: error in "next" command} -body {
    set z for
    catch {$z {set i 0} {$i < 5} {set} {set j 4}} msg
    set errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"
    ("for" loop-end command)
    invoked from within
"$z {set i 0} {$i < 5} {set} {set j 4}"}
test for-6.14 {Tcl_ForObjCmd: long command body} {






|












|










|







 







|







 







|







 







|









|










|







 







|







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
..
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
..
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
...
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
...
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for.test,v 1.16 2006/10/09 19:15:44 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Basic "for" operation.

test for-1.1 {TclCompileForCmd: missing initial command} {
    list [catch {for} msg] $msg
} {1 {wrong # args: should be "for start test next command"}}
test for-1.2 {TclCompileForCmd: error in initial command} -body {
    list [catch {for {set}} msg] $msg $::errorInfo
} -match glob -result {1 {wrong # args: should be "for start test next command"} {wrong # args: should be "for start test next command"
    while *ing
"for {set}"}}
catch {unset i}
test for-1.3 {TclCompileForCmd: missing test expression} {
    catch {for {set i 0}} msg
    set msg
} {wrong # args: should be "for start test next command"}
test for-1.4 {TclCompileForCmd: error in test expression} -body {
    catch {for {set i 0} {$i<}} msg
    set ::errorInfo
} -match glob -result {wrong # args: should be "for start test next command"
    while *ing
"for {set i 0} {$i<}"}
test for-1.5 {TclCompileForCmd: test expression is enclosed in quotes} {
    set i 0
    for {} "$i > 5" {incr i} {}
} {}
................................................................................
} {wrong # args: should be "for start test next command"}
test for-1.7 {TclCompileForCmd: missing command body} {
    catch {for {set i 0} {$i < 5} {incr i}} msg
    set msg
} {wrong # args: should be "for start test next command"}
test for-1.8 {TclCompileForCmd: error compiling command body} -body {
    catch {for {set i 0} {$i < 5} {incr i} {set}} msg
    set ::errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
catch {unset a}
test for-1.9 {TclCompileForCmd: simple command body} {
    set a {}
    for {set i 1} {$i<6} {set i [expr $i+1]} {
................................................................................
    set x2 {; append a x2}
    set a {}
    for {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2
    set a
} {x1}
test for-1.12 {TclCompileForCmd: error in "next" command} -body {
    catch {for {set i 0} {$i < 5} {set} {format $i}} msg
    set ::errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
test for-1.13 {TclCompileForCmd: long command body} {
    set a {}
    for {set i 1} {$i<6} {set i [expr $i+1]} {
	if $i==4 break
................................................................................
test for-6.5 {Tcl_ForObjCmd: number of args} {
    set z for
    catch {$z {set i 0} {$i < 5} {incr i} {body} extra} msg
    set msg
} {wrong # args: should be "for start test next command"}
test for-6.6 {Tcl_ForObjCmd: error in initial command} -body {
    set z for
    list [catch {$z {set} {$i < 5} {incr i} {body}} msg] $msg $::errorInfo
} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"
    ("for" initial command)
    invoked from within
"$z {set} {$i < 5} {incr i} {body}"}}
test for-6.7 {Tcl_ForObjCmd: error in test expression} -body {
    set z for
    catch {$z {set i 0} {i < 5} {incr i} {body}}
    set ::errorInfo
} -match glob -result {*"$z {set i 0} {i < 5} {incr i} {body}"}
test for-6.8 {Tcl_ForObjCmd: test expression is enclosed in quotes} {
    set z for
    set i 0
    $z {set i 6} "$i > 5" {incr i} {set y $i}
    set i
} 6
test for-6.9 {Tcl_ForObjCmd: error executing command body} -body {
    set z for
    catch {$z {set i 0} {$i < 5} {incr i} {set}} msg
    set ::errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"
    ("for" body line 1)
    invoked from within
"$z {set i 0} {$i < 5} {incr i} {set}"}
test for-6.10 {Tcl_ForObjCmd: simple command body} {
................................................................................
    set a {}
    $z {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2
    set a
} {x1}
test for-6.13 {Tcl_ForObjCmd: error in "next" command} -body {
    set z for
    catch {$z {set i 0} {$i < 5} {set} {set j 4}} msg
    set ::errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"
    ("for" loop-end command)
    invoked from within
"$z {set i 0} {$i < 5} {set} {set j 4}"}
test for-6.14 {Tcl_ForObjCmd: long command body} {

Changes to tests/http.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#
# RCS: @(#) $Id: http.test,v 1.42 2006/09/16 00:19:42 hobbs Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

if {[catch {package require http 2} version]} {
................................................................................
    set postResult [list PostStart]
    if {[catch {
	set t [http::geturl $badposturl -querychannel $fp -command asyncCB \
		-queryprogress postProgress]
	http::wait $t
	upvar #0 $t state
    } err]} {
	puts $errorInfo
	error $err
    }

    removeFile outdata
    list [http::status $t] [http::code $t]
} {ok {HTTP/1.0 200 Data follows}}
test http-3.13 {http::geturl socket leak test} {






|







 







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#
# RCS: @(#) $Id: http.test,v 1.43 2006/10/09 19:15:44 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

if {[catch {package require http 2} version]} {
................................................................................
    set postResult [list PostStart]
    if {[catch {
	set t [http::geturl $badposturl -querychannel $fp -command asyncCB \
		-queryprogress postProgress]
	http::wait $t
	upvar #0 $t state
    } err]} {
	puts $::errorInfo
	error $err
    }

    removeFile outdata
    list [http::status $t] [http::code $t]
} {ok {HTTP/1.0 200 Data follows}}
test http-3.13 {http::geturl socket leak test} {

Changes to tests/if.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
..
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
...
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
...
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
...
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
...
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
...
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
...
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: if.test,v 1.11 2006/08/22 18:10:44 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Basic "if" operation.
................................................................................
test if-1.1 {TclCompileIfCmd: missing if/elseif test} {
    list [catch {if} msg] $msg
} {1 {wrong # args: no expression after "if" argument}}
test if-1.2 {TclCompileIfCmd: error in if/elseif test} {
    list [catch {if {[error "error in condition"]} foo} msg] $msg
} {1 {error in condition}}
test if-1.3 {TclCompileIfCmd: error in if/elseif test} -body {
    list [catch {if {1+}} msg] $msg $errorInfo
} -match glob -result {1 * {*"if {1+}"}}
test if-1.4 {TclCompileIfCmd: if/elseif test in braces} {
    set a {}
    if {1<2} {set a 1}
    set a
} {1}
test if-1.5 {TclCompileIfCmd: if/elseif test not in braces} {
................................................................................
test if-1.9 {TclCompileIfCmd: missing "then" body} {
    set a {}
    catch {if 1<2 then} msg 
    set msg
} {wrong # args: no script following "then" argument}
test if-1.10 {TclCompileIfCmd: error in "then" body} -body {
    set a {}
    list [catch {if {$a!="xxx"} then {set}} msg] $msg $errorInfo
} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}}
test if-1.11 {TclCompileIfCmd: error in "then" body} {
    list [catch {if 2 then {[error "error in then clause"]}} msg] $msg
} {1 {error in then clause}}
test if-1.12 {TclCompileIfCmd: "then" body in quotes} {
................................................................................
test if-2.3 {TclCompileIfCmd: missing expression after "elseif"} {
    set a {}
    catch {if 1<2 {set a 1} elseif} msg 
    set msg
} {wrong # args: no expression after "elseif" argument}
test if-2.4 {TclCompileIfCmd: error in expression after "elseif"} -body {
    set a {}
    list [catch {if 3>4 {set a 1} elseif {1>}} msg] $msg $errorInfo
} -match glob -result {1 * {*"if 3>4 {set a 1} elseif {1>}"}}
test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long "elseif" body} {
    catch {unset i}
    set a {}
    if 1>2 {
	set a 1
	while {$a != "xxx"} {
................................................................................
    set a {}
    catch {if 2<1 {set a 1} else} msg 
    set msg
} {wrong # args: no script following "else" argument}
test if-3.4 {TclCompileIfCmd: error compiling body after "else"} -body {
    set a {}
    catch {if 2<1 {set a 1} else {set}} msg 
    set errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
test if-3.5 {TclCompileIfCmd: extra arguments after "else" argument} {
    set a {}
    catch {if 2<1 {set a 1} else {set a 2} or something} msg 
    set msg
................................................................................

test if-5.2 {if cmd with computed command names: error in if/elseif test} {
    set z if
    list [catch {$z {[error "error in condition"]} foo} msg] $msg
} {1 {error in condition}}
test if-5.3 {if cmd with computed command names: error in if/elseif test} -body {
    set z if
    list [catch {$z {1+}} msg] $msg $errorInfo
} -match glob -result {1 * {*"$z {1+}"}}
test if-5.4 {if cmd with computed command names: if/elseif test in braces} {
    set z if
    set a {}
    $z {1<2} {set a 1}
    set a
} {1}
................................................................................
    set a {}
    catch {$z 1<2 then} msg 
    set msg
} {wrong # args: no script following "then" argument}
test if-5.10 {if cmd with computed command names: error in "then" body} -body {
    set z if
    set a {}
    list [catch {$z {$a!="xxx"} then {set}} msg] $msg $errorInfo
} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"
    invoked from within
"$z {$a!="xxx"} then {set}"}}
test if-5.11 {if cmd with computed command names: error in "then" body} {
    set z if
................................................................................
    set a {}
    catch {$z 1<2 {set a 1} elseif} msg 
    set msg
} {wrong # args: no expression after "elseif" argument}
test if-6.4 {if cmd with computed command names: error in expression after "elseif"} -body {
    set z if
    set a {}
    list [catch {$z 3>4 {set a 1} elseif {1>}} msg] $msg $errorInfo
} -match glob -result {1 * {*"$z 3>4 {set a 1} elseif {1>}"}}
test if-6.5 {if cmd with computed command names: test jumpFalse instruction replacement after long "elseif" body} {
    set z if
    catch {unset i}
    set a {}
    $z 1>2 {
	set a 1
................................................................................
    catch {$z 2<1 {set a 1} else} msg 
    set msg
} {wrong # args: no script following "else" argument}
test if-7.4 {if cmd with computed command names: error compiling body after "else"} -body {
    set z if
    set a {}
    catch {$z 2<1 {set a 1} else {set}} msg 
    set errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"
    invoked from within
"$z 2<1 {set a 1} else {set}"}
test if-7.5 {if cmd with computed command names: extra arguments after "else" argument} {
    set z if






|







 







|







 







|







 







|







 







|







 







|







 







|







 







|







 







|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
..
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
...
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
...
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
...
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
...
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
...
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
...
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: if.test,v 1.12 2006/10/09 19:15:44 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Basic "if" operation.
................................................................................
test if-1.1 {TclCompileIfCmd: missing if/elseif test} {
    list [catch {if} msg] $msg
} {1 {wrong # args: no expression after "if" argument}}
test if-1.2 {TclCompileIfCmd: error in if/elseif test} {
    list [catch {if {[error "error in condition"]} foo} msg] $msg
} {1 {error in condition}}
test if-1.3 {TclCompileIfCmd: error in if/elseif test} -body {
    list [catch {if {1+}} msg] $msg $::errorInfo
} -match glob -result {1 * {*"if {1+}"}}
test if-1.4 {TclCompileIfCmd: if/elseif test in braces} {
    set a {}
    if {1<2} {set a 1}
    set a
} {1}
test if-1.5 {TclCompileIfCmd: if/elseif test not in braces} {
................................................................................
test if-1.9 {TclCompileIfCmd: missing "then" body} {
    set a {}
    catch {if 1<2 then} msg 
    set msg
} {wrong # args: no script following "then" argument}
test if-1.10 {TclCompileIfCmd: error in "then" body} -body {
    set a {}
    list [catch {if {$a!="xxx"} then {set}} msg] $msg $::errorInfo
} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}}
test if-1.11 {TclCompileIfCmd: error in "then" body} {
    list [catch {if 2 then {[error "error in then clause"]}} msg] $msg
} {1 {error in then clause}}
test if-1.12 {TclCompileIfCmd: "then" body in quotes} {
................................................................................
test if-2.3 {TclCompileIfCmd: missing expression after "elseif"} {
    set a {}
    catch {if 1<2 {set a 1} elseif} msg 
    set msg
} {wrong # args: no expression after "elseif" argument}
test if-2.4 {TclCompileIfCmd: error in expression after "elseif"} -body {
    set a {}
    list [catch {if 3>4 {set a 1} elseif {1>}} msg] $msg $::errorInfo
} -match glob -result {1 * {*"if 3>4 {set a 1} elseif {1>}"}}
test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long "elseif" body} {
    catch {unset i}
    set a {}
    if 1>2 {
	set a 1
	while {$a != "xxx"} {
................................................................................
    set a {}
    catch {if 2<1 {set a 1} else} msg 
    set msg
} {wrong # args: no script following "else" argument}
test if-3.4 {TclCompileIfCmd: error compiling body after "else"} -body {
    set a {}
    catch {if 2<1 {set a 1} else {set}} msg 
    set ::errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
test if-3.5 {TclCompileIfCmd: extra arguments after "else" argument} {
    set a {}
    catch {if 2<1 {set a 1} else {set a 2} or something} msg 
    set msg
................................................................................

test if-5.2 {if cmd with computed command names: error in if/elseif test} {
    set z if
    list [catch {$z {[error "error in condition"]} foo} msg] $msg
} {1 {error in condition}}
test if-5.3 {if cmd with computed command names: error in if/elseif test} -body {
    set z if
    list [catch {$z {1+}} msg] $msg $::errorInfo
} -match glob -result {1 * {*"$z {1+}"}}
test if-5.4 {if cmd with computed command names: if/elseif test in braces} {
    set z if
    set a {}
    $z {1<2} {set a 1}
    set a
} {1}
................................................................................
    set a {}
    catch {$z 1<2 then} msg 
    set msg
} {wrong # args: no script following "then" argument}
test if-5.10 {if cmd with computed command names: error in "then" body} -body {
    set z if
    set a {}
    list [catch {$z {$a!="xxx"} then {set}} msg] $msg $::errorInfo
} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"
    invoked from within
"$z {$a!="xxx"} then {set}"}}
test if-5.11 {if cmd with computed command names: error in "then" body} {
    set z if
................................................................................
    set a {}
    catch {$z 1<2 {set a 1} elseif} msg 
    set msg
} {wrong # args: no expression after "elseif" argument}
test if-6.4 {if cmd with computed command names: error in expression after "elseif"} -body {
    set z if
    set a {}
    list [catch {$z 3>4 {set a 1} elseif {1>}} msg] $msg $::errorInfo
} -match glob -result {1 * {*"$z 3>4 {set a 1} elseif {1>}"}}
test if-6.5 {if cmd with computed command names: test jumpFalse instruction replacement after long "elseif" body} {
    set z if
    catch {unset i}
    set a {}
    $z 1>2 {
	set a 1
................................................................................
    catch {$z 2<1 {set a 1} else} msg 
    set msg
} {wrong # args: no script following "else" argument}
test if-7.4 {if cmd with computed command names: error compiling body after "else"} -body {
    set z if
    set a {}
    catch {$z 2<1 {set a 1} else {set}} msg 
    set ::errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"
    invoked from within
"$z 2<1 {set a 1} else {set}"}
test if-7.5 {if cmd with computed command names: extra arguments after "else" argument} {
    set z if

Changes to tests/incr-old.test.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
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
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: incr-old.test,v 1.9 2006/02/09 17:34:42 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

catch {unset x}
................................................................................
} {1 {wrong # args: should be "incr varName ?increment?"}}
test incr-old-2.3 {incr errors} {
    catch {unset x}
    incr x
} 1
test incr-old-2.4 {incr errors} {
    set x abc
    list [catch {incr x} msg] $msg $errorInfo
} {1 {expected integer but got "abc"} {expected integer but got "abc"
    while executing
"incr x"}}
test incr-old-2.5 {incr errors} {
    set x 123
    list [catch {incr x 1a} msg] $msg $errorInfo
} {1 {expected integer but got "1a"} {expected integer but got "1a"
    (reading increment)
    invoked from within
"incr x 1a"}}
test incr-old-2.6 {incr errors} -body {
    proc readonly args {error "variable is read-only"}
    set x 123
    trace var x w readonly
    list [catch {incr x 1} msg] $msg $errorInfo
} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
    while executing
*
"incr x 1"}}
catch {unset x}
test incr-old-2.7 {incr errors} {
    set x -






|







 







|





|








|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
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
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: incr-old.test,v 1.10 2006/10/09 19:15:44 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

catch {unset x}
................................................................................
} {1 {wrong # args: should be "incr varName ?increment?"}}
test incr-old-2.3 {incr errors} {
    catch {unset x}
    incr x
} 1
test incr-old-2.4 {incr errors} {
    set x abc
    list [catch {incr x} msg] $msg $::errorInfo
} {1 {expected integer but got "abc"} {expected integer but got "abc"
    while executing
"incr x"}}
test incr-old-2.5 {incr errors} {
    set x 123
    list [catch {incr x 1a} msg] $msg $::errorInfo
} {1 {expected integer but got "1a"} {expected integer but got "1a"
    (reading increment)
    invoked from within
"incr x 1a"}}
test incr-old-2.6 {incr errors} -body {
    proc readonly args {error "variable is read-only"}
    set x 123
    trace var x w readonly
    list [catch {incr x 1} msg] $msg $::errorInfo
} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
    while executing
*
"incr x 1"}}
catch {unset x}
test incr-old-2.7 {incr errors} {
    set x -

Changes to tests/incr.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
...
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
...
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
...
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: incr.test,v 1.13 2006/03/08 16:07:43 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Basic "incr" operation.
................................................................................
test incr-1.18 {TclCompileIncrCmd: increment given, simple int} {
    set i 5
    incr i -100
} -95
test incr-1.19 {TclCompileIncrCmd: increment given, but erroneous} -body {
    set i 5
    catch {incr i [set]} msg
    set errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
test incr-1.20 {TclCompileIncrCmd: increment given, in quotes} {
    set i 25
    incr i "-100"
} -75
................................................................................


test incr-1.26 {TclCompileIncrCmd: runtime error, bad variable name} {
    unset -nocomplain {"foo}
    incr {"foo}
} 1
test incr-1.27 {TclCompileIncrCmd: runtime error, bad variable name} -body {
    list [catch {incr [set]} msg] $msg $errorInfo
} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}}
test incr-1.28 {TclCompileIncrCmd: runtime error, readonly variable} -body {
    proc readonly args {error "variable is read-only"}
    set x 123
    trace var x w readonly
    list [catch {incr x 1} msg] $msg $errorInfo
} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
    while executing
*
"incr x 1"}}
catch {unset x}
test incr-1.29 {TclCompileIncrCmd: runtime error, bad variable value} {
    set x "  -  "
................................................................................
    set i 5
    $z i -100
} -95
test incr-2.19 {incr command (not compiled): increment given, but erroneous} -body {
    set z incr
    set i 5
    catch {$z i [set]} msg
    set errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
test incr-2.20 {incr command (not compiled): increment given, in quotes} {
    set z incr
    set i 25
    $z i "-100"
................................................................................
test incr-2.26 {incr command (not compiled): runtime error, bad variable name} {
    unset -nocomplain {"foo}
    set z incr
    $z {"foo}
} 1
test incr-2.27 {incr command (not compiled): runtime error, bad variable name} -body {
    set z incr
    list [catch {$z [set]} msg] $msg $errorInfo
} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}}
test incr-2.28 {incr command (not compiled): runtime error, readonly variable} -body {
    set z incr
    proc readonly args {error "variable is read-only"}
    set x 123
    trace var x w readonly
    list [catch {$z x 1} msg] $msg $errorInfo
} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
    while executing
*
"$z x 1"}}
catch {unset x}
test incr-2.29 {incr command (not compiled): runtime error, bad variable value} {
    set z incr
    set x "  -  "
    list [catch {$z x 1} msg] $msg
} {1 {expected integer but got "  -  "}}
test incr-2.30 {incr command (not compiled): bad increment} {
    set z incr
    set x 0
    list [catch {$z x 1a} msg] $msg $errorInfo
} {1 {expected integer but got "1a"} {expected integer but got "1a"
    (reading increment)
    invoked from within
"$z x 1a"}}
test incr-2.31 {incr command (compiled): bad increment} {
    list [catch {incr x 1a} msg] $msg $errorInfo
} {1 {expected integer but got "1a"} {expected integer but got "1a"
    (reading increment)
    invoked from within
"incr x 1a"}}

test incr-3.1 {increment by wide amount: bytecode route} {
    set x 0






|







 







|







 







|







|







 







|







 







|








|













|





|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
...
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
...
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
...
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: incr.test,v 1.14 2006/10/09 19:15:44 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Basic "incr" operation.
................................................................................
test incr-1.18 {TclCompileIncrCmd: increment given, simple int} {
    set i 5
    incr i -100
} -95
test incr-1.19 {TclCompileIncrCmd: increment given, but erroneous} -body {
    set i 5
    catch {incr i [set]} msg
    set ::errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
test incr-1.20 {TclCompileIncrCmd: increment given, in quotes} {
    set i 25
    incr i "-100"
} -75
................................................................................


test incr-1.26 {TclCompileIncrCmd: runtime error, bad variable name} {
    unset -nocomplain {"foo}
    incr {"foo}
} 1
test incr-1.27 {TclCompileIncrCmd: runtime error, bad variable name} -body {
    list [catch {incr [set]} msg] $msg $::errorInfo
} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}}
test incr-1.28 {TclCompileIncrCmd: runtime error, readonly variable} -body {
    proc readonly args {error "variable is read-only"}
    set x 123
    trace var x w readonly
    list [catch {incr x 1} msg] $msg $::errorInfo
} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
    while executing
*
"incr x 1"}}
catch {unset x}
test incr-1.29 {TclCompileIncrCmd: runtime error, bad variable value} {
    set x "  -  "
................................................................................
    set i 5
    $z i -100
} -95
test incr-2.19 {incr command (not compiled): increment given, but erroneous} -body {
    set z incr
    set i 5
    catch {$z i [set]} msg
    set ::errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
test incr-2.20 {incr command (not compiled): increment given, in quotes} {
    set z incr
    set i 25
    $z i "-100"
................................................................................
test incr-2.26 {incr command (not compiled): runtime error, bad variable name} {
    unset -nocomplain {"foo}
    set z incr
    $z {"foo}
} 1
test incr-2.27 {incr command (not compiled): runtime error, bad variable name} -body {
    set z incr
    list [catch {$z [set]} msg] $msg $::errorInfo
} -match glob -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}}
test incr-2.28 {incr command (not compiled): runtime error, readonly variable} -body {
    set z incr
    proc readonly args {error "variable is read-only"}
    set x 123
    trace var x w readonly
    list [catch {$z x 1} msg] $msg $::errorInfo
} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
    while executing
*
"$z x 1"}}
catch {unset x}
test incr-2.29 {incr command (not compiled): runtime error, bad variable value} {
    set z incr
    set x "  -  "
    list [catch {$z x 1} msg] $msg
} {1 {expected integer but got "  -  "}}
test incr-2.30 {incr command (not compiled): bad increment} {
    set z incr
    set x 0
    list [catch {$z x 1a} msg] $msg $::errorInfo
} {1 {expected integer but got "1a"} {expected integer but got "1a"
    (reading increment)
    invoked from within
"$z x 1a"}}
test incr-2.31 {incr command (compiled): bad increment} {
    list [catch {incr x 1a} msg] $msg $::errorInfo
} {1 {expected integer but got "1a"} {expected integer but got "1a"
    (reading increment)
    invoked from within
"incr x 1a"}}

test incr-3.1 {increment by wide amount: bytecode route} {
    set x 0

Changes to tests/interp.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
....
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: interp.test,v 1.48 2006/01/18 19:48:11 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.1
    namespace import -force ::tcltest::*
}

testConstraint testinterpdelete [llength [info commands testinterpdelete]]
................................................................................
    proc MyError {secret} {
	return -code error "msg"
    }
    proc MyTestAlias {interp args} {
	MyError "some secret"
    }
    interp alias $interp test {} MyTestAlias $interp;
    set res [interp eval $interp {catch test;set errorInfo}]
    interp delete $interp;
    set res
} {msg
    while executing
"MyError "some secret""
    (procedure "MyTestAlias" line 2)
    invoked from within
................................................................................
    proc MyError {secret} {
	return -code error "msg"
    }
    proc MyTestAlias {interp args} {
	MyError "some secret"
    }
    interp alias $interp test {} MyTestAlias $interp;
    set res [interp eval $interp {catch test;set errorInfo}]
    interp delete $interp;
    set res
} {msg
    while executing
"test"}

# Interps & Namespaces






|







 







|







 







|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
....
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: interp.test,v 1.49 2006/10/09 19:15:44 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.1
    namespace import -force ::tcltest::*
}

testConstraint testinterpdelete [llength [info commands testinterpdelete]]
................................................................................
    proc MyError {secret} {
	return -code error "msg"
    }
    proc MyTestAlias {interp args} {
	MyError "some secret"
    }
    interp alias $interp test {} MyTestAlias $interp;
    set res [interp eval $interp {catch test;set ::errorInfo}]
    interp delete $interp;
    set res
} {msg
    while executing
"MyError "some secret""
    (procedure "MyTestAlias" line 2)
    invoked from within
................................................................................
    proc MyError {secret} {
	return -code error "msg"
    }
    proc MyTestAlias {interp args} {
	MyError "some secret"
    }
    interp alias $interp test {} MyTestAlias $interp;
    set res [interp eval $interp {catch test;set ::errorInfo}]
    interp delete $interp;
    set res
} {msg
    while executing
"test"}

# Interps & Namespaces

Changes to tests/io.test.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
....
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
....
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: io.test,v 1.71 2006/03/21 11:12:29 dkf Exp $

if {[catch {package require tcltest 2}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2 required."
    return
}
namespace eval ::tcl::test::io {
    namespace import ::tcltest::*
................................................................................
    #
    # The flush below will get a SIGPIPE. This is an expected part of
    # test and indicates that the test operates correctly. If you run
    # this test under a debugger, the signal will by intercepted unless
    # you disable the debugger's signal interception.
    #
    if {[catch {flush $f} msg]} {
	set x [list 1 $msg $errorCode]
	catch {close $f}
    } else {
	if {[catch {close $f} msg]} {
	    set x [list 1 $msg $errorCode]
	} else {
	    set x {this was supposed to fail and did not}
	}
    }
    regsub {".*":} $x {"":} x
    string tolower $x
} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}}
................................................................................
    set x [gets $f]
    close $f
    lappend x [viewFile test3]
} {zzy abzzy}
test io-40.16 {tilde substitution in open} -constraints makeFileInHome -setup {
    makeFile {Some text} _test_ ~
} -body {
    file exists [file join $env(HOME) _test_]
} -cleanup {
    removeFile _test_ ~
} -result 1
test io-40.17 {tilde substitution in open} {
    set home $env(HOME)
    unset env(HOME)
    set x [list [catch {open ~/foo} msg] $msg]
    set env(HOME) $home
    set x
} {1 {couldn't find HOME environment variable to expand path}}

test io-41.1 {Tcl_FileeventCmd: errors} {fileevent} {
    list [catch {fileevent foo} msg] $msg
} {1 {wrong # args: should be "fileevent channelId event ?script?"}}
test io-41.2 {Tcl_FileeventCmd: errors} {fileevent} {






|







 







|



|







 







|




|
|

|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
....
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
....
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: io.test,v 1.72 2006/10/09 19:15:45 msofer Exp $

if {[catch {package require tcltest 2}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2 required."
    return
}
namespace eval ::tcl::test::io {
    namespace import ::tcltest::*
................................................................................
    #
    # The flush below will get a SIGPIPE. This is an expected part of
    # test and indicates that the test operates correctly. If you run
    # this test under a debugger, the signal will by intercepted unless
    # you disable the debugger's signal interception.
    #
    if {[catch {flush $f} msg]} {
	set x [list 1 $msg $::errorCode]
	catch {close $f}
    } else {
	if {[catch {close $f} msg]} {
	    set x [list 1 $msg $::errorCode]
	} else {
	    set x {this was supposed to fail and did not}
	}
    }
    regsub {".*":} $x {"":} x
    string tolower $x
} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}}
................................................................................
    set x [gets $f]
    close $f
    lappend x [viewFile test3]
} {zzy abzzy}
test io-40.16 {tilde substitution in open} -constraints makeFileInHome -setup {
    makeFile {Some text} _test_ ~
} -body {
    file exists [file join $::env(HOME) _test_]
} -cleanup {
    removeFile _test_ ~
} -result 1
test io-40.17 {tilde substitution in open} {
    set home $::env(HOME)
    unset ::env(HOME)
    set x [list [catch {open ~/foo} msg] $msg]
    set ::env(HOME) $home
    set x
} {1 {couldn't find HOME environment variable to expand path}}

test io-41.1 {Tcl_FileeventCmd: errors} {fileevent} {
    list [catch {fileevent foo} msg] $msg
} {1 {wrong # args: should be "fileevent channelId event ?script?"}}
test io-41.2 {Tcl_FileeventCmd: errors} {fileevent} {

Changes to tests/ioCmd.test.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
...
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
...
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
...
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
...
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
...
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
...
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: ioCmd.test,v 1.28 2006/03/16 18:23:00 andreas_kupries Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Custom constraints used in this file
................................................................................
test iocmd-4.3 {read command} {
   list [catch {read aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-4.4 {read command} {
   list [catch {read -nonewline} msg] $msg
} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"}}
test iocmd-4.5 {read command} {
   list [catch {read -nonew file4} msg] $msg $errorCode
} {1 {can not find channel named "-nonew"} NONE}
test iocmd-4.6 {read command} {
   list [catch {read stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.7 {read command} {
   list [catch {read -nonewline stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
................................................................................
test iocmd-4.8 {read command with incorrect combination of arguments} {
    file delete $path(test1)
    set f [open $path(test1) w]
    puts $f "Two lines: this one"
    puts $f "and this one"
    close $f
    set f [open $path(test1)]
    set x [list [catch {read -nonewline $f 20 z} msg] $msg $errorCode]
    close $f
    set x
} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"} NONE}
test iocmd-4.9 {read command} {
    list [catch {read stdin foo} msg] $msg $errorCode
} {1 {bad argument "foo": should be "nonewline"} NONE}
test iocmd-4.10 {read command} {
    list [catch {read file107} msg] $msg $errorCode
} {1 {can not find channel named "file107"} NONE}

set path(test3) [makeFile {} test3]

test iocmd-4.11 {read command} {
    set f [open $path(test3) w]
    set x [list [catch {read $f} msg] $msg $errorCode]
    close $f
    string compare [string tolower $x] \
	[list 1 [format "channel \"%s\" wasn't opened for reading" $f] none]
} 0
test iocmd-4.12 {read command} {
    set f [open $path(test1)]
    set x [list [catch {read $f 12z} msg] $msg $errorCode]
    close $f
    set x
} {1 {expected integer but got "12z"} NONE}

test iocmd-5.1 {seek command} {
    list [catch {seek} msg] $msg
} {1 {wrong # args: should be "seek channelId offset ?origin?"}}
................................................................................
	close $tty
    }
} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -mode, -handshake, -pollinterval, -sysbuffer, -timeout, -ttycontrol, or -xchar}
# TODO: Test parsing of serial channel options (nonportable, since requires an
# open channel to work with).

test iocmd-9.1 {eof command} {
    list [catch {eof} msg] $msg $errorCode
} {1 {wrong # args: should be "eof channelId"} NONE}
test iocmd-9.2 {eof command} {
    list [catch {eof a b} msg] $msg $errorCode
} {1 {wrong # args: should be "eof channelId"} NONE}
test iocmd-9.3 {eof command} {
    catch {close file100}
    list [catch {eof file100} msg] $msg $errorCode
} {1 {can not find channel named "file100"} NONE}

# The tests for Tcl_ExecObjCmd are in exec.test

test iocmd-10.1 {fblocked command} {
    list [catch {fblocked} msg] $msg
} {1 {wrong # args: should be "fblocked channelId"}}
................................................................................
set path(test4) [makeFile {} test4]
set path(test5) [makeFile {} test5]

file delete $path(test5)
test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} {
    set f [open $path(test4) w]
    close $f
    list [catch {open "| cat < $path(test4) > $path(test5)" w} msg] $msg $errorCode
} {1 {can't write input to command: standard input was redirected} NONE}
test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} {
    list [catch {open "| echo > $path(test5)" r} msg] $msg $errorCode
} {1 {can't read output from command: standard output was redirected} NONE}
test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} {
    list [catch {open "| echo > $path(test5)" r+} msg] $msg $errorCode
} {1 {can't read output from command: standard output was redirected} NONE}

test iocmd-12.1 {POSIX open access modes: RDONLY} {
    file delete $path(test1)
    set f [open $path(test1) w]
    puts $f "Two lines: this one"
    puts $f "and this one"
................................................................................
    string compare $x $y
} 0
test iocmd-12.5 {POSIX open access modes: RDWR} -match regexp -body {
    file delete $path(test3)
    open $path(test3) RDWR
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test iocmd-12.6 {POSIX open access modes: errors} {
    concat [catch {open $path(test3) "FOO \{BAR BAZ"} msg] $msg\n$errorInfo
} "1 unmatched open brace in list
unmatched open brace in list
    while processing open access modes \"FOO {BAR BAZ\"
    invoked from within
\"open \$path(test3) \"FOO \\{BAR BAZ\"\""
test iocmd-12.7 {POSIX open access modes: errors} {
  list [catch {open $path(test3) {FOO BAR BAZ}} msg] $msg
................................................................................
test iocmd-13.4 {errors in open command} {
    list [catch {open $path(test1) rw} msg] $msg
} {1 {illegal access mode "rw"}}
test iocmd-13.5 {errors in open command} {
    list [catch {open $path(test1) r+1} msg] $msg
} {1 {illegal access mode "r+1"}}
test iocmd-13.6 {errors in open command} {
    set msg [list [catch {open _non_existent_} msg] $msg $errorCode]
    regsub [file join {} _non_existent_] $msg "_non_existent_" msg
    string tolower $msg
} {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}}
test iocmd-13.7 {errors in open command} {
    list [catch {open $path(test1) b} msg] $msg
} {1 {illegal access mode "b"}}
test iocmd-13.8 {errors in open command} {
................................................................................
} -cleanup {
    removeFile out
    # Ensure that channels are gone, even if body failed to do so
    foreach ch $chans {catch {close $ch}}
} -result {0 1 2 3 4 5 6 7 8 9}

test iocmd-14.1 {file id parsing errors} {
    list [catch {eof gorp} msg] $msg $errorCode
} {1 {can not find channel named "gorp"} NONE}
test iocmd-14.2 {file id parsing errors} {
    list [catch {eof filex} msg] $msg
} {1 {can not find channel named "filex"}}
test iocmd-14.3 {file id parsing errors} {
    list [catch {eof file12a} msg] $msg
} {1 {can not find channel named "file12a"}}






|







 







|







 







|




|


|






|






|







 







|


|



|







 







|


|


|







 







|







 







|







 







|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
...
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
...
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
...
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
...
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
...
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
...
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: ioCmd.test,v 1.29 2006/10/09 19:15:45 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Custom constraints used in this file
................................................................................
test iocmd-4.3 {read command} {
   list [catch {read aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-4.4 {read command} {
   list [catch {read -nonewline} msg] $msg
} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"}}
test iocmd-4.5 {read command} {
   list [catch {read -nonew file4} msg] $msg $::errorCode
} {1 {can not find channel named "-nonew"} NONE}
test iocmd-4.6 {read command} {
   list [catch {read stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.7 {read command} {
   list [catch {read -nonewline stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
................................................................................
test iocmd-4.8 {read command with incorrect combination of arguments} {
    file delete $path(test1)
    set f [open $path(test1) w]
    puts $f "Two lines: this one"
    puts $f "and this one"
    close $f
    set f [open $path(test1)]
    set x [list [catch {read -nonewline $f 20 z} msg] $msg $::errorCode]
    close $f
    set x
} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"} NONE}
test iocmd-4.9 {read command} {
    list [catch {read stdin foo} msg] $msg $::errorCode
} {1 {bad argument "foo": should be "nonewline"} NONE}
test iocmd-4.10 {read command} {
    list [catch {read file107} msg] $msg $::errorCode
} {1 {can not find channel named "file107"} NONE}

set path(test3) [makeFile {} test3]

test iocmd-4.11 {read command} {
    set f [open $path(test3) w]
    set x [list [catch {read $f} msg] $msg $::errorCode]
    close $f
    string compare [string tolower $x] \
	[list 1 [format "channel \"%s\" wasn't opened for reading" $f] none]
} 0
test iocmd-4.12 {read command} {
    set f [open $path(test1)]
    set x [list [catch {read $f 12z} msg] $msg $::errorCode]
    close $f
    set x
} {1 {expected integer but got "12z"} NONE}

test iocmd-5.1 {seek command} {
    list [catch {seek} msg] $msg
} {1 {wrong # args: should be "seek channelId offset ?origin?"}}
................................................................................
	close $tty
    }
} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -mode, -handshake, -pollinterval, -sysbuffer, -timeout, -ttycontrol, or -xchar}
# TODO: Test parsing of serial channel options (nonportable, since requires an
# open channel to work with).

test iocmd-9.1 {eof command} {
    list [catch {eof} msg] $msg $::errorCode
} {1 {wrong # args: should be "eof channelId"} NONE}
test iocmd-9.2 {eof command} {
    list [catch {eof a b} msg] $msg $::errorCode
} {1 {wrong # args: should be "eof channelId"} NONE}
test iocmd-9.3 {eof command} {
    catch {close file100}
    list [catch {eof file100} msg] $msg $::errorCode
} {1 {can not find channel named "file100"} NONE}

# The tests for Tcl_ExecObjCmd are in exec.test

test iocmd-10.1 {fblocked command} {
    list [catch {fblocked} msg] $msg
} {1 {wrong # args: should be "fblocked channelId"}}
................................................................................
set path(test4) [makeFile {} test4]
set path(test5) [makeFile {} test5]

file delete $path(test5)
test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} {
    set f [open $path(test4) w]
    close $f
    list [catch {open "| cat < $path(test4) > $path(test5)" w} msg] $msg $::errorCode
} {1 {can't write input to command: standard input was redirected} NONE}
test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} {
    list [catch {open "| echo > $path(test5)" r} msg] $msg $::errorCode
} {1 {can't read output from command: standard output was redirected} NONE}
test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} {
    list [catch {open "| echo > $path(test5)" r+} msg] $msg $::errorCode
} {1 {can't read output from command: standard output was redirected} NONE}

test iocmd-12.1 {POSIX open access modes: RDONLY} {
    file delete $path(test1)
    set f [open $path(test1) w]
    puts $f "Two lines: this one"
    puts $f "and this one"
................................................................................
    string compare $x $y
} 0
test iocmd-12.5 {POSIX open access modes: RDWR} -match regexp -body {
    file delete $path(test3)
    open $path(test3) RDWR
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test iocmd-12.6 {POSIX open access modes: errors} {
    concat [catch {open $path(test3) "FOO \{BAR BAZ"} msg] $msg\n$::errorInfo
} "1 unmatched open brace in list
unmatched open brace in list
    while processing open access modes \"FOO {BAR BAZ\"
    invoked from within
\"open \$path(test3) \"FOO \\{BAR BAZ\"\""
test iocmd-12.7 {POSIX open access modes: errors} {
  list [catch {open $path(test3) {FOO BAR BAZ}} msg] $msg
................................................................................
test iocmd-13.4 {errors in open command} {
    list [catch {open $path(test1) rw} msg] $msg
} {1 {illegal access mode "rw"}}
test iocmd-13.5 {errors in open command} {
    list [catch {open $path(test1) r+1} msg] $msg
} {1 {illegal access mode "r+1"}}
test iocmd-13.6 {errors in open command} {
    set msg [list [catch {open _non_existent_} msg] $msg $::errorCode]
    regsub [file join {} _non_existent_] $msg "_non_existent_" msg
    string tolower $msg
} {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}}
test iocmd-13.7 {errors in open command} {
    list [catch {open $path(test1) b} msg] $msg
} {1 {illegal access mode "b"}}
test iocmd-13.8 {errors in open command} {
................................................................................
} -cleanup {
    removeFile out
    # Ensure that channels are gone, even if body failed to do so
    foreach ch $chans {catch {close $ch}}
} -result {0 1 2 3 4 5 6 7 8 9}

test iocmd-14.1 {file id parsing errors} {
    list [catch {eof gorp} msg] $msg $::errorCode
} {1 {can not find channel named "gorp"} NONE}
test iocmd-14.2 {file id parsing errors} {
    list [catch {eof filex} msg] $msg
} {1 {can not find channel named "filex"}}
test iocmd-14.3 {file id parsing errors} {
    list [catch {eof file12a} msg] $msg
} {1 {can not find channel named "file12a"}}

Changes to tests/load.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
#
# 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.15 2006/03/21 11:12:29 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Figure out what extension is used for shared libraries on this
................................................................................
test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] {
    list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg
} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}}

test load-3.1 {error in _Init procedure, same interpreter} \
	[list $dll $loaded] {
    list [catch {load [file join $testDir pkge$ext] pkge} msg] \
	    $msg $errorInfo $errorCode
} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
    while executing
"open non_existent"
    invoked from within
"if 44 {open non_existent}"
    invoked from within
"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}}
test load-3.2 {error in _Init procedure, slave interpreter} \
	[list $dll $loaded] {
    catch {interp delete x}
    interp create x
    set errorCode foo
    set errorInfo bar
    set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \
	    $msg $errorInfo $errorCode]
    interp delete x
    set result
} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
    while executing
"open non_existent"
    invoked from within
"if 44 {open non_existent}"






|







 







|











|
|

|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
#
# 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.16 2006/10/09 19:15:45 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Figure out what extension is used for shared libraries on this
................................................................................
test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] {
    list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg
} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}}

test load-3.1 {error in _Init procedure, same interpreter} \
	[list $dll $loaded] {
    list [catch {load [file join $testDir pkge$ext] pkge} msg] \
	    $msg $::errorInfo $::errorCode
} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
    while executing
"open non_existent"
    invoked from within
"if 44 {open non_existent}"
    invoked from within
"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}}
test load-3.2 {error in _Init procedure, slave interpreter} \
	[list $dll $loaded] {
    catch {interp delete x}
    interp create x
    set ::errorCode foo
    set ::errorInfo bar
    set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \
	    $msg $::errorInfo $::errorCode]
    interp delete x
    set result
} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
    while executing
"open non_existent"
    invoked from within
"if 44 {open non_existent}"

Changes to tests/misc.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
# Copyright (c) 1992-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: misc.test,v 1.10 2004/09/22 22:23:40 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint testhashsystemhash [llength [info commands testhashsystemhash]]
................................................................................
	# this is a bogus comment
	# this is a bogus comment
	# this is a bogus comment
	# this is a bogus comment
	# this is a bogus comment
    "
    set msg {}
    join [list [catch tstProc msg] $msg $errorInfo] \n
} [subst -novariables -nocommands {1
missing close-brace for variable name
missing close-brace for variable name
    while executing
"set tst $a([winfo name $\{zz)
	# this is a bogus comment
	# this is a bogus comment






|







 







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
# Copyright (c) 1992-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: misc.test,v 1.11 2006/10/09 19:15:45 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint testhashsystemhash [llength [info commands testhashsystemhash]]
................................................................................
	# this is a bogus comment
	# this is a bogus comment
	# this is a bogus comment
	# this is a bogus comment
	# this is a bogus comment
    "
    set msg {}
    join [list [catch tstProc msg] $msg $::errorInfo] \n
} [subst -novariables -nocommands {1
missing close-brace for variable name
missing close-brace for variable name
    while executing
"set tst $a([winfo name $\{zz)
	# this is a bogus comment
	# this is a bogus comment

Changes to tests/namespace.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
....
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
....
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
....
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
....
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: namespace.test,v 1.56 2006/02/28 15:47:10 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

#
................................................................................
    }
    test_ns_1::q
} {314160}
test namespace-25.5 {NamespaceEvalCmd, multiple args} {
    namespace eval test_ns_1 "set" "v"
} {314159}
test namespace-25.6 {NamespaceEvalCmd, error in eval'd script} {
    list [catch {namespace eval test_ns_1 {xxxx}} msg] $msg $errorInfo
} {1 {invalid command name "xxxx"} {invalid command name "xxxx"
    while executing
"xxxx"
    (in namespace eval "::test_ns_1" script line 1)
    invoked from within
"namespace eval test_ns_1 {xxxx}"}}
test namespace-25.7 {NamespaceEvalCmd, error in eval'd script} {
    list [catch {namespace eval test_ns_1 {error foo bar baz}} msg] $msg $errorInfo
} {1 foo {bar
    (in namespace eval "::test_ns_1" script line 1)
    invoked from within
"namespace eval test_ns_1 {error foo bar baz}"}}
test namespace-25.8 {NamespaceEvalCmd, error in eval'd script} {
    list [catch {namespace eval test_ns_1 error foo bar baz} msg] $msg $errorInfo
} {1 foo {bar
    (in namespace eval "::test_ns_1" script line 1)
    invoked from within
"namespace eval test_ns_1 error foo bar baz"}}
catch {unset v}
test namespace-25.9 {NamespaceEvalCmd, 545325} {
    namespace eval test_ns_1 info level 0
................................................................................
    namespace eval ns {
	namespace export {[a-z]*}
	proc Magic {ensemble subcmd args} {
	    error foobar
	}
	namespace ensemble create -unknown ::ns::Magic
    }
    list [catch {ns spong} msg] $msg $errorInfo [namespace delete ns]
} {1 foobar {foobar
    while executing
"error foobar"
    (procedure "::ns::Magic" line 2)
    invoked from within
"::ns::Magic ::ns spong"
    (ensemble unknown subcommand handler)
................................................................................
    namespace eval ns {
	namespace export {[a-z]*}
	proc Magic {ensemble subcmd args} {
	    return -code break
	}
	namespace ensemble create -unknown ::ns::Magic
    }
    list [catch {ns spong} msg] $msg $errorInfo [namespace delete ns]
} {1 {unknown subcommand handler returned bad code: break} {unknown subcommand handler returned bad code: break
    result of ensemble unknown subcommand handler: ::ns::Magic ::ns spong
    invoked from within
"ns spong"} {}}
test namespace-47.5 {ensemble: unknown handler} {
    namespace ensemble create -command foo -unknown bar
    proc bar {args} {
................................................................................
    set result
} {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo 0 {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo} {-map {} -namespace :: -prefixes 1 -subcommands {} -unknown bar}}
test namespace-47.6 {ensemble: unknown handler} {
    namespace ensemble create -command foo -unknown bar
    proc bar {args} {
	return "\{"
    }
    set result [list [catch {foo bar} msg] $msg $errorInfo]
    rename foo {}
    set result
} {1 {unmatched open brace in list} {unmatched open brace in list
    while parsing result of ensemble unknown subcommand handler
    invoked from within
"foo bar"}}







|







 







|







|





|







 







|







 







|







 







|







7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
....
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
....
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
....
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
....
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: namespace.test,v 1.57 2006/10/09 19:15:45 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

#
................................................................................
    }
    test_ns_1::q
} {314160}
test namespace-25.5 {NamespaceEvalCmd, multiple args} {
    namespace eval test_ns_1 "set" "v"
} {314159}
test namespace-25.6 {NamespaceEvalCmd, error in eval'd script} {
    list [catch {namespace eval test_ns_1 {xxxx}} msg] $msg $::errorInfo
} {1 {invalid command name "xxxx"} {invalid command name "xxxx"
    while executing
"xxxx"
    (in namespace eval "::test_ns_1" script line 1)
    invoked from within
"namespace eval test_ns_1 {xxxx}"}}
test namespace-25.7 {NamespaceEvalCmd, error in eval'd script} {
    list [catch {namespace eval test_ns_1 {error foo bar baz}} msg] $msg $::errorInfo
} {1 foo {bar
    (in namespace eval "::test_ns_1" script line 1)
    invoked from within
"namespace eval test_ns_1 {error foo bar baz}"}}
test namespace-25.8 {NamespaceEvalCmd, error in eval'd script} {
    list [catch {namespace eval test_ns_1 error foo bar baz} msg] $msg $::errorInfo
} {1 foo {bar
    (in namespace eval "::test_ns_1" script line 1)
    invoked from within
"namespace eval test_ns_1 error foo bar baz"}}
catch {unset v}
test namespace-25.9 {NamespaceEvalCmd, 545325} {
    namespace eval test_ns_1 info level 0
................................................................................
    namespace eval ns {
	namespace export {[a-z]*}
	proc Magic {ensemble subcmd args} {
	    error foobar
	}
	namespace ensemble create -unknown ::ns::Magic
    }
    list [catch {ns spong} msg] $msg $::errorInfo [namespace delete ns]
} {1 foobar {foobar
    while executing
"error foobar"
    (procedure "::ns::Magic" line 2)
    invoked from within
"::ns::Magic ::ns spong"
    (ensemble unknown subcommand handler)
................................................................................
    namespace eval ns {
	namespace export {[a-z]*}
	proc Magic {ensemble subcmd args} {
	    return -code break
	}
	namespace ensemble create -unknown ::ns::Magic
    }
    list [catch {ns spong} msg] $msg $::errorInfo [namespace delete ns]
} {1 {unknown subcommand handler returned bad code: break} {unknown subcommand handler returned bad code: break
    result of ensemble unknown subcommand handler: ::ns::Magic ::ns spong
    invoked from within
"ns spong"} {}}
test namespace-47.5 {ensemble: unknown handler} {
    namespace ensemble create -command foo -unknown bar
    proc bar {args} {
................................................................................
    set result
} {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo 0 {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo} {-map {} -namespace :: -prefixes 1 -subcommands {} -unknown bar}}
test namespace-47.6 {ensemble: unknown handler} {
    namespace ensemble create -command foo -unknown bar
    proc bar {args} {
	return "\{"
    }
    set result [list [catch {foo bar} msg] $msg $::errorInfo]
    rename foo {}
    set result
} {1 {unmatched open brace in list} {unmatched open brace in list
    while parsing result of ensemble unknown subcommand handler
    invoked from within
"foo bar"}}

Changes to tests/parse.test.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
...
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
...
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
...
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
...
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
...
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
...
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
...
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
...
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
...
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
#
# 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.24 2006/03/21 11:12:29 dkf Exp $

if {[catch {package require tcltest 2.0.2}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
    return
}

namespace eval ::tcl::test::parse {
................................................................................
test parse-3.5 {Tcl_ParseCommand procedure, quoted words} testparser {
    testparser {foo "a b c" d "efg";} 0
} {- {foo "a b c" d "efg";} 4 simple foo 1 text foo 0 simple {"a b c"} 1 text {a b c} 0 simple d 1 text d 0 simple {"efg"} 1 text efg 0 {}}
test parse-3.6 {Tcl_ParseCommand procedure, words in braces} testparser {
    testparser {foo {a $b [concat foo]} {c d}} 0
} {- {foo {a $b [concat foo]} {c d}} 3 simple foo 1 text foo 0 simple {{a $b [concat foo]}} 1 text {a $b [concat foo]} 0 simple {{c d}} 1 text {c d} 0 {}}
test parse-3.7 {Tcl_ParseCommand procedure, error in unquoted word} testparser {
    list [catch {testparser "foo \$\{abc" 0} msg] $msg $errorInfo
} {1 {missing close-brace for variable name} missing\ close-brace\ for\ variable\ name\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\$\\\{abc\"\ 0\"}

test parse-4.1 {Tcl_ParseCommand procedure, simple words} testparser {
    testparser {foo} 0
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-4.2 {Tcl_ParseCommand procedure, simple words} testparser {
    testparser {{abc}} 0
................................................................................
test parse-5.4 {Tcl_ParseCommand procedure, word terminator is command terminator} testparser {
    testparser "foo; bar" 0
} {- {foo;} 1 simple foo 1 text foo 0 { bar}}
test parse-5.5 {Tcl_ParseCommand procedure, word terminator is end of string} testparser {
    testparser "\"foo\" bar" 5
} {- {"foo"} 1 simple {"foo"} 1 text foo 0 { bar}}
test parse-5.6 {Tcl_ParseCommand procedure, junk after close quote} testparser {
    list [catch {testparser {foo "bar"x} 0} msg] $msg $errorInfo
} {1 {extra characters after close-quote} {extra characters after close-quote
    (remainder of script: "x")
    invoked from within
"testparser {foo "bar"x} 0"}}
test parse-5.7 {Tcl_ParseCommand procedure, backslash-newline after close quote} testparser {
    testparser "foo \"bar\"\\\nx" 0
} {- foo\ \"bar\"\\\nx 3 simple foo 1 text foo 0 simple {"bar"} 1 text bar 0 simple x 1 text x 0 {}}
test parse-5.8 {Tcl_ParseCommand procedure, junk after close brace} testparser {
    list [catch {testparser {foo {bar}x} 0} msg] $msg $errorInfo
} {1 {extra characters after close-brace} {extra characters after close-brace
    (remainder of script: "x")
    invoked from within
"testparser {foo {bar}x} 0"}}
test parse-5.9 {Tcl_ParseCommand procedure, backslash-newline after close brace} testparser {
    testparser "foo {bar}\\\nx" 0
} {- foo\ \{bar\}\\\nx 3 simple foo 1 text foo 0 simple {{bar}} 1 text bar 0 simple x 1 text x 0 {}}
test parse-5.10 {Tcl_ParseCommand procedure, multiple deletion of non-static buffer} testparser {
    # This test is designed to catch bug 1681.
    list [catch {testparser "a \"\\1\\2\\3\\4\\5\\6\\7\\8\\9\\1\\2\\3\\4\\5\\6\\7\\8" 0} msg] $msg $errorInfo
} "1 {missing \"} {missing \"
    (remainder of script: \"\"\\1\\2\\3\\4\\5\\6\\7\\8\\9\\1\\2\\3\\4\\5\\6\\7\\8\")
    invoked from within
\"testparser \"a \\\"\\\\1\\\\2\\\\3\\\\4\\\\5\\\\6\\\\7\\\\8\\\\9\\\\1\\\\2\\\\3\\\\4\\\\5\\\\6\\\\7\\\\8\" 0\"}"

test parse-5.11 {Tcl_ParseCommand: {expand} parsing} testparser {
    testparser {{expan}} 0
................................................................................
test parse-6.5 {ParseTokens procedure, command substitution} testparser {
    testparser {[foo $x bar]z} 0
} {- {[foo $x bar]z} 1 word {[foo $x bar]z} 2 command {[foo $x bar]} 0 text z 0 {}}
test parse-6.6 {ParseTokens procedure, command substitution} testparser {
    testparser {[foo \] [a b]]} 0
} {- {[foo \] [a b]]} 1 word {[foo \] [a b]]} 1 command {[foo \] [a b]]} 0 {}}
test parse-6.7 {ParseTokens procedure, error in command substitution} testparser {
    list [catch {testparser {a [b {}c d] e} 0} msg] $msg $errorInfo
} {1 {extra characters after close-brace} {extra characters after close-brace
    (remainder of script: "c d] e")
    invoked from within
"testparser {a [b {}c d] e} 0"}}
test parse-6.8 {ParseTokens procedure, error in command substitution} {
    info complete {a [b {}c d]}
} {1}
................................................................................
	expr 1+1
	#this is a comment ]}
} {0}
test parse-6.11 {ParseTokens procedure, memory allocation for big nested command} testparser {
    testparser {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 0
} {- {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 1 word {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 1 command {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 0 {}}
test parse-6.12 {ParseTokens procedure, missing close bracket} testparser {
    list [catch {testparser {[foo $x bar} 0} msg] $msg $errorInfo
} {1 {missing close-bracket} {missing close-bracket
    (remainder of script: "[foo $x bar")
    invoked from within
"testparser {[foo $x bar} 0"}}
test parse-6.13 {ParseTokens procedure, backslash-newline without continuation line} testparser {
    list [catch {testparser "\"a b\\\n" 0} msg] $msg $errorInfo
} {1 {missing "} missing\ \"\n\ \ \ \ (remainder\ of\ script:\ \"\"a\ b\\\n\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\\\"a\ b\\\\\\n\"\ 0\"}
test parse-6.14 {ParseTokens procedure, backslash-newline} testparser {
    testparser "b\\\nc" 0
} {- b\\\nc 2 simple b 1 text b 0 simple c 1 text c 0 {}}
test parse-6.15 {ParseTokens procedure, backslash-newline} testparser {
    testparser "\"b\\\nc\"" 0
} {- \"b\\\nc\" 1 word \"b\\\nc\" 3 text b 0 backslash \\\n 0 text c 0 {}}
................................................................................
test parse-9.1 {Tcl_LogCommandInfo, line numbers} testevalex {
    catch {unset x}
    list [catch {testevalex {for {} 1 {} {


	# asdf
	set x
    }}}] $errorInfo
} {1 {can't read "x": no such variable
    while executing
"set x"
    ("for" body line 5)
    invoked from within
"for {} 1 {} {

................................................................................
"testevalex {for {} 1 {} {


	# asdf
	set x
    }}"}}
test parse-9.2 {Tcl_LogCommandInfo, truncating long commands} {
    list [catch {set a b 111111111 222222222 333333333 444444444 555555555 666666666 777777777 888888888 999999999 000000000 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee fffffffff ggggggggg}] $errorInfo
} {1 {wrong # args: should be "set varName ?newValue?"
    while executing
"set a b 111111111 222222222 333333333 444444444 555555555 666666666 777777777 888888888 999999999 000000000 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd ee..."}}

test parse-10.1 {Tcl_EvalTokens, simple text} testevalex {
    testevalex {concat test}
} {test}
................................................................................
test parse-12.6 {Tcl_ParseVarName procedure, braced variable name} testparser {
    testparser {${..[]b}cd} 0
} {- {${..[]b}cd} 1 word {${..[]b}cd} 3 variable {${..[]b}} 1 text {..[]b} 0 text cd 0 {}}
test parse-12.7 {Tcl_ParseVarName procedure, braced variable name} testparser {
    testparser "\$\{\{\} " 0
} {- \$\{\{\}\  1 word \$\{\{\} 2 variable \$\{\{\} 1 text \{ 0 {}}
test parse-12.8 {Tcl_ParseVarName procedure, missing close brace} testparser {
    list [catch {testparser "$\{abc" 0} msg] $msg $errorInfo
} {1 {missing close-brace for variable name} missing\ close-brace\ for\ variable\ name\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\$\\\{abc\"\ 0\"}
test parse-12.9 {Tcl_ParseVarName procedure, missing close brace} testparsevarname {
    list [catch {testparsevarname {${bcd}} 4 0} msg] $msg
} {1 {missing close-brace for variable name}}
test parse-12.10 {Tcl_ParseVarName procedure, missing close brace} testparsevarname {
    list [catch {testparsevarname {${bc}} 4 0} msg] $msg
} {1 {missing close-brace for variable name}}
................................................................................
test parse-12.21 {Tcl_ParseVarName procedure, array reference} testparser {
    testparser {$x(ab$cde[foo bar])} 0
} {- {$x(ab$cde[foo bar])} 1 word {$x(ab$cde[foo bar])} 6 variable {$x(ab$cde[foo bar])} 5 text x 0 text ab 0 variable {$cde} 1 text cde 0 command {[foo bar]} 0 {}}
test parse-12.22 {Tcl_ParseVarName procedure, array reference} testparser {
    testparser {$x([cmd arg]zz)} 0
} {- {$x([cmd arg]zz)} 1 word {$x([cmd arg]zz)} 4 variable {$x([cmd arg]zz)} 3 text x 0 command {[cmd arg]} 0 text zz 0 {}}
test parse-12.23 {Tcl_ParseVarName procedure, missing close paren in array reference} testparser {
    list [catch {testparser {$x(poiu} 0} msg] $msg $errorInfo
} {1 {missing )} {missing )
    (remainder of script: "(poiu")
    invoked from within
"testparser {$x(poiu} 0"}}
test parse-12.24 {Tcl_ParseVarName procedure, missing close paren in array reference} testparsevarname {
    list [catch {testparsevarname {$ab(cd)} 6 0} msg] $msg $errorInfo
} {1 {missing )} {missing )
    (remainder of script: "(cd)")
    invoked from within
"testparsevarname {$ab(cd)} 6 0"}}
test parse-12.25 {Tcl_ParseVarName procedure, nested array reference} testparser {
    testparser {$x(a$y(b$z))} 0
} {- {$x(a$y(b$z))} 1 word {$x(a$y(b$z))} 8 variable {$x(a$y(b$z))} 7 text x 0 text a 0 variable {$y(b$z)} 4 text y 0 text b 0 variable {$z} 1 text z 0 {}}
................................................................................
test parse-14.5 {Tcl_ParseBraces procedure, nested braces} testparser {
    testparser {foo {{a {b} c} {} {d e}}} 0
} {- {foo {{a {b} c} {} {d e}}} 2 simple foo 1 text foo 0 simple {{{a {b} c} {} {d e}}} 1 text {{a {b} c} {} {d e}} 0 {}}
test parse-14.6 {Tcl_ParseBraces procedure, backslashes in words in braces} testparser {
    testparser "foo {a \\n\\\{}" 0
} {- {foo {a \n\{}} 2 simple foo 1 text foo 0 simple {{a \n\{}} 1 text {a \n\{} 0 {}}
test parse-14.7 {Tcl_ParseBraces procedure, missing continuation line in braces} testparser {
    list [catch {testparser "\{abc\\\n" 0} msg] $msg $errorInfo
} {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\\\n\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\\\{abc\\\\\\n\"\ 0\"}
test parse-14.8 {Tcl_ParseBraces procedure, backslash-newline in braces} testparser {
    testparser "foo {\\\nx}" 0
} {- foo\ \{\\\nx\} 2 simple foo 1 text foo 0 word \{\\\nx\} 2 backslash \\\n 0 text x 0 {}}
test parse-14.9 {Tcl_ParseBraces procedure, backslash-newline in braces} testparser {
    testparser "foo {a \\\n   b}" 0
} {- foo\ \{a\ \\\n\ \ \ b\} 2 simple foo 1 text foo 0 word \{a\ \\\n\ \ \ b\} 3 text {a } 0 backslash \\\n\ \ \  0 text b 0 {}}
................................................................................
test parse-14.10 {Tcl_ParseBraces procedure, backslash-newline in braces} testparser {
    testparser "foo {xyz\\\n }" 0
} {- foo\ \{xyz\\\n\ \} 2 simple foo 1 text foo 0 word \{xyz\\\n\ \} 2 text xyz 0 backslash \\\n\  0 {}}
test parse-14.11 {Tcl_ParseBraces procedure, empty braced string} testparser {
    testparser {foo {}} 0
} {- {foo {}} 2 simple foo 1 text foo 0 simple {{}} 1 text {} 0 {}}
test parse-14.12 {Tcl_ParseBraces procedure, missing close brace} testparser {
    list [catch {testparser "foo \{xy\\\nz" 0} msg] $msg $errorInfo
} {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{xy\\\nz\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\{xy\\\\\\nz\"\ 0\"}

test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} testparser {
    testparser [bytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-15.2 {Tcl_ParseQuotedString procedure, computing string length} testparser {
    testparser "foo bar" -1
} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}}
test parse-15.3 {Tcl_ParseQuotedString procedure, word is quoted string} testparser {
    testparser {foo "a b c" d "efg";} 0
} {- {foo "a b c" d "efg";} 4 simple foo 1 text foo 0 simple {"a b c"} 1 text {a b c} 0 simple d 1 text d 0 simple {"efg"} 1 text efg 0 {}}
test parse-15.4 {Tcl_ParseQuotedString procedure, garbage after quoted string} testparser {
    list [catch {testparser {foo "a b c"d} 0} msg] $msg $errorInfo
} {1 {extra characters after close-quote} {extra characters after close-quote
    (remainder of script: "d")
    invoked from within
"testparser {foo "a b c"d} 0"}}

test parse-15.5 {CommandComplete procedure} {
    info complete ""






|







 







|







 







|








|









|







 







|







 







|





|







 







|







 







|







 







|







 







|





|







 







|







 







|












|







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
...
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
...
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
...
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
...
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
...
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
...
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
...
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
...
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
...
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
#
# 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.25 2006/10/09 19:15:45 msofer Exp $

if {[catch {package require tcltest 2.0.2}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
    return
}

namespace eval ::tcl::test::parse {
................................................................................
test parse-3.5 {Tcl_ParseCommand procedure, quoted words} testparser {
    testparser {foo "a b c" d "efg";} 0
} {- {foo "a b c" d "efg";} 4 simple foo 1 text foo 0 simple {"a b c"} 1 text {a b c} 0 simple d 1 text d 0 simple {"efg"} 1 text efg 0 {}}
test parse-3.6 {Tcl_ParseCommand procedure, words in braces} testparser {
    testparser {foo {a $b [concat foo]} {c d}} 0
} {- {foo {a $b [concat foo]} {c d}} 3 simple foo 1 text foo 0 simple {{a $b [concat foo]}} 1 text {a $b [concat foo]} 0 simple {{c d}} 1 text {c d} 0 {}}
test parse-3.7 {Tcl_ParseCommand procedure, error in unquoted word} testparser {
    list [catch {testparser "foo \$\{abc" 0} msg] $msg $::errorInfo
} {1 {missing close-brace for variable name} missing\ close-brace\ for\ variable\ name\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\$\\\{abc\"\ 0\"}

test parse-4.1 {Tcl_ParseCommand procedure, simple words} testparser {
    testparser {foo} 0
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-4.2 {Tcl_ParseCommand procedure, simple words} testparser {
    testparser {{abc}} 0
................................................................................
test parse-5.4 {Tcl_ParseCommand procedure, word terminator is command terminator} testparser {
    testparser "foo; bar" 0
} {- {foo;} 1 simple foo 1 text foo 0 { bar}}
test parse-5.5 {Tcl_ParseCommand procedure, word terminator is end of string} testparser {
    testparser "\"foo\" bar" 5
} {- {"foo"} 1 simple {"foo"} 1 text foo 0 { bar}}
test parse-5.6 {Tcl_ParseCommand procedure, junk after close quote} testparser {
    list [catch {testparser {foo "bar"x} 0} msg] $msg $::errorInfo
} {1 {extra characters after close-quote} {extra characters after close-quote
    (remainder of script: "x")
    invoked from within
"testparser {foo "bar"x} 0"}}
test parse-5.7 {Tcl_ParseCommand procedure, backslash-newline after close quote} testparser {
    testparser "foo \"bar\"\\\nx" 0
} {- foo\ \"bar\"\\\nx 3 simple foo 1 text foo 0 simple {"bar"} 1 text bar 0 simple x 1 text x 0 {}}
test parse-5.8 {Tcl_ParseCommand procedure, junk after close brace} testparser {
    list [catch {testparser {foo {bar}x} 0} msg] $msg $::errorInfo
} {1 {extra characters after close-brace} {extra characters after close-brace
    (remainder of script: "x")
    invoked from within
"testparser {foo {bar}x} 0"}}
test parse-5.9 {Tcl_ParseCommand procedure, backslash-newline after close brace} testparser {
    testparser "foo {bar}\\\nx" 0
} {- foo\ \{bar\}\\\nx 3 simple foo 1 text foo 0 simple {{bar}} 1 text bar 0 simple x 1 text x 0 {}}
test parse-5.10 {Tcl_ParseCommand procedure, multiple deletion of non-static buffer} testparser {
    # This test is designed to catch bug 1681.
    list [catch {testparser "a \"\\1\\2\\3\\4\\5\\6\\7\\8\\9\\1\\2\\3\\4\\5\\6\\7\\8" 0} msg] $msg $::errorInfo
} "1 {missing \"} {missing \"
    (remainder of script: \"\"\\1\\2\\3\\4\\5\\6\\7\\8\\9\\1\\2\\3\\4\\5\\6\\7\\8\")
    invoked from within
\"testparser \"a \\\"\\\\1\\\\2\\\\3\\\\4\\\\5\\\\6\\\\7\\\\8\\\\9\\\\1\\\\2\\\\3\\\\4\\\\5\\\\6\\\\7\\\\8\" 0\"}"

test parse-5.11 {Tcl_ParseCommand: {expand} parsing} testparser {
    testparser {{expan}} 0
................................................................................
test parse-6.5 {ParseTokens procedure, command substitution} testparser {
    testparser {[foo $x bar]z} 0
} {- {[foo $x bar]z} 1 word {[foo $x bar]z} 2 command {[foo $x bar]} 0 text z 0 {}}
test parse-6.6 {ParseTokens procedure, command substitution} testparser {
    testparser {[foo \] [a b]]} 0
} {- {[foo \] [a b]]} 1 word {[foo \] [a b]]} 1 command {[foo \] [a b]]} 0 {}}
test parse-6.7 {ParseTokens procedure, error in command substitution} testparser {
    list [catch {testparser {a [b {}c d] e} 0} msg] $msg $::errorInfo
} {1 {extra characters after close-brace} {extra characters after close-brace
    (remainder of script: "c d] e")
    invoked from within
"testparser {a [b {}c d] e} 0"}}
test parse-6.8 {ParseTokens procedure, error in command substitution} {
    info complete {a [b {}c d]}
} {1}
................................................................................
	expr 1+1
	#this is a comment ]}
} {0}
test parse-6.11 {ParseTokens procedure, memory allocation for big nested command} testparser {
    testparser {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 0
} {- {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 1 word {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 1 command {[$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b)]} 0 {}}
test parse-6.12 {ParseTokens procedure, missing close bracket} testparser {
    list [catch {testparser {[foo $x bar} 0} msg] $msg $::errorInfo
} {1 {missing close-bracket} {missing close-bracket
    (remainder of script: "[foo $x bar")
    invoked from within
"testparser {[foo $x bar} 0"}}
test parse-6.13 {ParseTokens procedure, backslash-newline without continuation line} testparser {
    list [catch {testparser "\"a b\\\n" 0} msg] $msg $::errorInfo
} {1 {missing "} missing\ \"\n\ \ \ \ (remainder\ of\ script:\ \"\"a\ b\\\n\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\\\"a\ b\\\\\\n\"\ 0\"}
test parse-6.14 {ParseTokens procedure, backslash-newline} testparser {
    testparser "b\\\nc" 0
} {- b\\\nc 2 simple b 1 text b 0 simple c 1 text c 0 {}}
test parse-6.15 {ParseTokens procedure, backslash-newline} testparser {
    testparser "\"b\\\nc\"" 0
} {- \"b\\\nc\" 1 word \"b\\\nc\" 3 text b 0 backslash \\\n 0 text c 0 {}}
................................................................................
test parse-9.1 {Tcl_LogCommandInfo, line numbers} testevalex {
    catch {unset x}
    list [catch {testevalex {for {} 1 {} {


	# asdf
	set x
    }}}] $::errorInfo
} {1 {can't read "x": no such variable
    while executing
"set x"
    ("for" body line 5)
    invoked from within
"for {} 1 {} {

................................................................................
"testevalex {for {} 1 {} {


	# asdf
	set x
    }}"}}
test parse-9.2 {Tcl_LogCommandInfo, truncating long commands} {
    list [catch {set a b 111111111 222222222 333333333 444444444 555555555 666666666 777777777 888888888 999999999 000000000 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee fffffffff ggggggggg}] $::errorInfo
} {1 {wrong # args: should be "set varName ?newValue?"
    while executing
"set a b 111111111 222222222 333333333 444444444 555555555 666666666 777777777 888888888 999999999 000000000 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd ee..."}}

test parse-10.1 {Tcl_EvalTokens, simple text} testevalex {
    testevalex {concat test}
} {test}
................................................................................
test parse-12.6 {Tcl_ParseVarName procedure, braced variable name} testparser {
    testparser {${..[]b}cd} 0
} {- {${..[]b}cd} 1 word {${..[]b}cd} 3 variable {${..[]b}} 1 text {..[]b} 0 text cd 0 {}}
test parse-12.7 {Tcl_ParseVarName procedure, braced variable name} testparser {
    testparser "\$\{\{\} " 0
} {- \$\{\{\}\  1 word \$\{\{\} 2 variable \$\{\{\} 1 text \{ 0 {}}
test parse-12.8 {Tcl_ParseVarName procedure, missing close brace} testparser {
    list [catch {testparser "$\{abc" 0} msg] $msg $::errorInfo
} {1 {missing close-brace for variable name} missing\ close-brace\ for\ variable\ name\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\$\\\{abc\"\ 0\"}
test parse-12.9 {Tcl_ParseVarName procedure, missing close brace} testparsevarname {
    list [catch {testparsevarname {${bcd}} 4 0} msg] $msg
} {1 {missing close-brace for variable name}}
test parse-12.10 {Tcl_ParseVarName procedure, missing close brace} testparsevarname {
    list [catch {testparsevarname {${bc}} 4 0} msg] $msg
} {1 {missing close-brace for variable name}}
................................................................................
test parse-12.21 {Tcl_ParseVarName procedure, array reference} testparser {
    testparser {$x(ab$cde[foo bar])} 0
} {- {$x(ab$cde[foo bar])} 1 word {$x(ab$cde[foo bar])} 6 variable {$x(ab$cde[foo bar])} 5 text x 0 text ab 0 variable {$cde} 1 text cde 0 command {[foo bar]} 0 {}}
test parse-12.22 {Tcl_ParseVarName procedure, array reference} testparser {
    testparser {$x([cmd arg]zz)} 0
} {- {$x([cmd arg]zz)} 1 word {$x([cmd arg]zz)} 4 variable {$x([cmd arg]zz)} 3 text x 0 command {[cmd arg]} 0 text zz 0 {}}
test parse-12.23 {Tcl_ParseVarName procedure, missing close paren in array reference} testparser {
    list [catch {testparser {$x(poiu} 0} msg] $msg $::errorInfo
} {1 {missing )} {missing )
    (remainder of script: "(poiu")
    invoked from within
"testparser {$x(poiu} 0"}}
test parse-12.24 {Tcl_ParseVarName procedure, missing close paren in array reference} testparsevarname {
    list [catch {testparsevarname {$ab(cd)} 6 0} msg] $msg $::errorInfo
} {1 {missing )} {missing )
    (remainder of script: "(cd)")
    invoked from within
"testparsevarname {$ab(cd)} 6 0"}}
test parse-12.25 {Tcl_ParseVarName procedure, nested array reference} testparser {
    testparser {$x(a$y(b$z))} 0
} {- {$x(a$y(b$z))} 1 word {$x(a$y(b$z))} 8 variable {$x(a$y(b$z))} 7 text x 0 text a 0 variable {$y(b$z)} 4 text y 0 text b 0 variable {$z} 1 text z 0 {}}
................................................................................
test parse-14.5 {Tcl_ParseBraces procedure, nested braces} testparser {
    testparser {foo {{a {b} c} {} {d e}}} 0
} {- {foo {{a {b} c} {} {d e}}} 2 simple foo 1 text foo 0 simple {{{a {b} c} {} {d e}}} 1 text {{a {b} c} {} {d e}} 0 {}}
test parse-14.6 {Tcl_ParseBraces procedure, backslashes in words in braces} testparser {
    testparser "foo {a \\n\\\{}" 0
} {- {foo {a \n\{}} 2 simple foo 1 text foo 0 simple {{a \n\{}} 1 text {a \n\{} 0 {}}
test parse-14.7 {Tcl_ParseBraces procedure, missing continuation line in braces} testparser {
    list [catch {testparser "\{abc\\\n" 0} msg] $msg $::errorInfo
} {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\\\n\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\\\{abc\\\\\\n\"\ 0\"}
test parse-14.8 {Tcl_ParseBraces procedure, backslash-newline in braces} testparser {
    testparser "foo {\\\nx}" 0
} {- foo\ \{\\\nx\} 2 simple foo 1 text foo 0 word \{\\\nx\} 2 backslash \\\n 0 text x 0 {}}
test parse-14.9 {Tcl_ParseBraces procedure, backslash-newline in braces} testparser {
    testparser "foo {a \\\n   b}" 0
} {- foo\ \{a\ \\\n\ \ \ b\} 2 simple foo 1 text foo 0 word \{a\ \\\n\ \ \ b\} 3 text {a } 0 backslash \\\n\ \ \  0 text b 0 {}}
................................................................................
test parse-14.10 {Tcl_ParseBraces procedure, backslash-newline in braces} testparser {
    testparser "foo {xyz\\\n }" 0
} {- foo\ \{xyz\\\n\ \} 2 simple foo 1 text foo 0 word \{xyz\\\n\ \} 2 text xyz 0 backslash \\\n\  0 {}}
test parse-14.11 {Tcl_ParseBraces procedure, empty braced string} testparser {
    testparser {foo {}} 0
} {- {foo {}} 2 simple foo 1 text foo 0 simple {{}} 1 text {} 0 {}}
test parse-14.12 {Tcl_ParseBraces procedure, missing close brace} testparser {
    list [catch {testparser "foo \{xy\\\nz" 0} msg] $msg $::errorInfo
} {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{xy\\\nz\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\{xy\\\\\\nz\"\ 0\"}

test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} testparser {
    testparser [bytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-15.2 {Tcl_ParseQuotedString procedure, computing string length} testparser {
    testparser "foo bar" -1
} {- {foo bar} 2 simple foo 1 text foo 0 simple bar 1 text bar 0 {}}
test parse-15.3 {Tcl_ParseQuotedString procedure, word is quoted string} testparser {
    testparser {foo "a b c" d "efg";} 0
} {- {foo "a b c" d "efg";} 4 simple foo 1 text foo 0 simple {"a b c"} 1 text {a b c} 0 simple d 1 text d 0 simple {"efg"} 1 text efg 0 {}}
test parse-15.4 {Tcl_ParseQuotedString procedure, garbage after quoted string} testparser {
    list [catch {testparser {foo "a b c"d} 0} msg] $msg $::errorInfo
} {1 {extra characters after close-quote} {extra characters after close-quote
    (remainder of script: "d")
    invoked from within
"testparser {foo "a b c"d} 0"}}

test parse-15.5 {CommandComplete procedure} {
    info complete ""

Changes to tests/parseOld.test.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: parseOld.test,v 1.13 2006/03/21 11:12:29 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint testwordend [llength [info commands testwordend]]
................................................................................
} {a b}

# The next test will fail on the Mac, 'cause the MSL uses a fixed sized
# buffer for %d conversions (LAME!).  I won't leave the test out, however,
# since MetroWerks may some day fix this.

test parseOld-10.14 {syntax errors} {
    list [catch {eval \$x[format "%01000d" 0](} msg] $msg $errorInfo
} {1 {missing )} {missing )
    while executing
"$x0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000..."
    ("eval" body line 1)
    invoked from within
"eval \$x[format "%01000d" 0]("}}
test parseOld-10.15 {syntax errors, missplaced braces} {






|







 







|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: parseOld.test,v 1.14 2006/10/09 19:15:45 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint testwordend [llength [info commands testwordend]]
................................................................................
} {a b}

# The next test will fail on the Mac, 'cause the MSL uses a fixed sized
# buffer for %d conversions (LAME!).  I won't leave the test out, however,
# since MetroWerks may some day fix this.

test parseOld-10.14 {syntax errors} {
    list [catch {eval \$x[format "%01000d" 0](} msg] $msg $::errorInfo
} {1 {missing )} {missing )
    while executing
"$x0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000..."
    ("eval" body line 1)
    invoked from within
"eval \$x[format "%01000d" 0]("}}
test parseOld-10.15 {syntax errors, missplaced braces} {

Changes to tests/pkg.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
...
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
...
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: pkg.test,v 1.20 2006/10/04 18:05:23 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Do all this in a slave interp to avoid garbaging the
................................................................................
    package forget t
    package unknown {}
    list [catch {package require t} msg] $msg
} {1 {can't find package t}}
test pkg-2.10 {Tcl_PkgRequire procedure, error in ifneeded script} -body {
    package forget t
    package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test"}
    list [catch {package require t 2.1} msg] $msg $errorInfo
} -match glob -result {1 {ifneeded test} {ifneeded test
    while executing
"error "ifneeded test""
    ("package ifneeded*" script)
    invoked from within
"package require t 2.1"}}
test pkg-2.11 {Tcl_PkgRequire procedure, ifneeded script doesn't provide package} -body {
................................................................................
} {{a b}}
test pkg-2.16 {Tcl_PkgRequire procedure, "package unknown" error} {
    proc pkgUnknown args {
	error "testing package unknown"
    }
    package forget t 
    package unknown pkgUnknown
    set result [list [catch {package require t} msg] $msg $errorInfo]
    package unknown {}
    set result
} {1 {testing package unknown} {testing package unknown
    while executing
"error "testing package unknown""
    (procedure "pkgUnknown" line 2)
    invoked from within
................................................................................
    package forget t
    package provide t 2.3
    list [catch {package require -exact t 2.2} msg] $msg
} {1 {version conflict for package "t": have 2.3, need 2.2-2.3}}
test pkg-2.25 {Tcl_PkgRequire procedure, error in ifneeded script} -body {
    package forget t
    package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test" EI}
    list [catch {package require t 2.1} msg] $msg $errorInfo
} -match glob -result {1 {ifneeded test} {EI
    ("package ifneeded*" script)
    invoked from within
"package require t 2.1"}}
test pkg-2.26 {Tcl_PkgRequire procedure, error in ifneeded script} -body {
    package forget t
    package ifneeded t 2.1 {package provide t 2.1; foreach x 1 {error "ifneeded test" EI}}
    list [catch {package require t 2.1} msg] $msg $errorInfo
} -match glob -result {1 {ifneeded test} {EI
    ("foreach" body line 1)
    invoked from within
"foreach x 1 {error "ifneeded test" EI}"
    ("package ifneeded*" script)
    invoked from within
"package require t 2.1"}}






|







 







|







 







|







 







|







|







7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
...
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
...
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: pkg.test,v 1.21 2006/10/09 19:15:45 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Do all this in a slave interp to avoid garbaging the
................................................................................
    package forget t
    package unknown {}
    list [catch {package require t} msg] $msg
} {1 {can't find package t}}
test pkg-2.10 {Tcl_PkgRequire procedure, error in ifneeded script} -body {
    package forget t
    package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test"}
    list [catch {package require t 2.1} msg] $msg $::errorInfo
} -match glob -result {1 {ifneeded test} {ifneeded test
    while executing
"error "ifneeded test""
    ("package ifneeded*" script)
    invoked from within
"package require t 2.1"}}
test pkg-2.11 {Tcl_PkgRequire procedure, ifneeded script doesn't provide package} -body {
................................................................................
} {{a b}}
test pkg-2.16 {Tcl_PkgRequire procedure, "package unknown" error} {
    proc pkgUnknown args {
	error "testing package unknown"
    }
    package forget t 
    package unknown pkgUnknown
    set result [list [catch {package require t} msg] $msg $::errorInfo]
    package unknown {}
    set result
} {1 {testing package unknown} {testing package unknown
    while executing
"error "testing package unknown""
    (procedure "pkgUnknown" line 2)
    invoked from within
................................................................................
    package forget t
    package provide t 2.3
    list [catch {package require -exact t 2.2} msg] $msg
} {1 {version conflict for package "t": have 2.3, need 2.2-2.3}}
test pkg-2.25 {Tcl_PkgRequire procedure, error in ifneeded script} -body {
    package forget t
    package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test" EI}
    list [catch {package require t 2.1} msg] $msg $::errorInfo
} -match glob -result {1 {ifneeded test} {EI
    ("package ifneeded*" script)
    invoked from within
"package require t 2.1"}}
test pkg-2.26 {Tcl_PkgRequire procedure, error in ifneeded script} -body {
    package forget t
    package ifneeded t 2.1 {package provide t 2.1; foreach x 1 {error "ifneeded test" EI}}
    list [catch {package require t 2.1} msg] $msg $::errorInfo
} -match glob -result {1 {ifneeded test} {EI
    ("foreach" body line 1)
    invoked from within
"foreach x 1 {error "ifneeded test" EI}"
    ("package ifneeded*" script)
    invoked from within
"package require t 2.1"}}

Changes to tests/proc-old.test.

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
...
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
...
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
...
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: proc-old.test,v 1.14 2006/02/01 19:26:02 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

catch {rename t1 ""}
................................................................................
test proc-old-5.13 {error conditions} {
    proc tproc {} {
	set a 22
	error "error in procedure"
	return
    }
    catch tproc msg
    set errorInfo
} {error in procedure
    while executing
"error "error in procedure""
    (procedure "tproc" line 3)
    invoked from within
"tproc"}
test proc-old-5.14 {error conditions} {
    proc tproc {} {
	set a 22
	break
	return
    }
    catch tproc msg
    set errorInfo
} {invoked "break" outside of a loop
    (procedure "tproc" line 1)
    invoked from within
"tproc"}
test proc-old-5.15 {error conditions} {
    proc tproc {} {
	set a 22
	continue
	return
    }
    catch tproc msg
    set errorInfo
} {invoked "continue" outside of a loop
    (procedure "tproc" line 1)
    invoked from within
"tproc"}
test proc-old-5.16 {error conditions} {
    proc foo args {
	global fooMsg
................................................................................
	set x 44
	trace var x u foo
	while {$x < 100} {
	    error "Nested error"
	}
    }
    set fooMsg "foo not called"
    list [catch tproc msg] $msg $errorInfo $fooMsg
} {1 {Nested error} {Nested error
    while executing
"error "Nested error""
    (procedure "tproc" line 5)
    invoked from within
"tproc"} {foo was called: x {} u}}

................................................................................
proc tproc code {
    return -code $code abc
}
test proc-old-7.1 {return with special completion code} {
    list [catch {tproc ok} msg] $msg
} {0 abc}
test proc-old-7.2 {return with special completion code} {
    list [catch {tproc error} msg] $msg $errorInfo $errorCode
} {1 abc {abc
    while executing
"tproc error"} NONE}
test proc-old-7.3 {return with special completion code} {
    list [catch {tproc return} msg] $msg
} {2 abc}
test proc-old-7.4 {return with special completion code} {
................................................................................
} {1 {}}
test proc-old-7.11 {return with special completion code} {
    proc tproc2 {} {
	global errorCode errorInfo
	catch {open _bad_file_name r} msg
	return -code error -errorinfo $errorInfo -errorcode $errorCode $msg
    }
    set msg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
    regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
    normalizeMsg $msg
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
    while executing
"open _bad_file_name r"
    invoked from within
"tproc2"} {posix enoent {no such file or directory}}}
test proc-old-7.12 {return with special completion code} {
    proc tproc2 {} {
	global errorCode errorInfo
	catch {open _bad_file_name r} msg
	return -code error -errorcode $errorCode $msg
    }
    set msg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
    regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
    normalizeMsg $msg
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
    while executing
"tproc2"} {posix enoent {no such file or directory}}}
test proc-old-7.13 {return with special completion code} {
    proc tproc2 {} {
	global errorCode errorInfo
	catch {open _bad_file_name r} msg
	return -code error -errorinfo $errorInfo $msg
    }
    set msg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
    regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
    normalizeMsg $msg
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
    while executing
"open _bad_file_name r"
    invoked from within
"tproc2"} none}
test proc-old-7.14 {return with special completion code} {
    proc tproc2 {} {
	global errorCode errorInfo
	catch {open _bad_file_name r} msg
	return -code error $msg
    }
    set msg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
    regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
    normalizeMsg $msg
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
    while executing
"tproc2"} none}
test proc-old-7.15 {return with special completion code} {
    list [catch {return -badOption foo message} msg] $msg






|







 







|













|











|







 







|







 







|







 







|













|











|













|







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
...
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
...
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
...
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: proc-old.test,v 1.15 2006/10/09 19:15:45 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

catch {rename t1 ""}
................................................................................
test proc-old-5.13 {error conditions} {
    proc tproc {} {
	set a 22
	error "error in procedure"
	return
    }
    catch tproc msg
    set ::errorInfo
} {error in procedure
    while executing
"error "error in procedure""
    (procedure "tproc" line 3)
    invoked from within
"tproc"}
test proc-old-5.14 {error conditions} {
    proc tproc {} {
	set a 22
	break
	return
    }
    catch tproc msg
    set ::errorInfo
} {invoked "break" outside of a loop
    (procedure "tproc" line 1)
    invoked from within
"tproc"}
test proc-old-5.15 {error conditions} {
    proc tproc {} {
	set a 22
	continue
	return
    }
    catch tproc msg
    set ::errorInfo
} {invoked "continue" outside of a loop
    (procedure "tproc" line 1)
    invoked from within
"tproc"}
test proc-old-5.16 {error conditions} {
    proc foo args {
	global fooMsg
................................................................................
	set x 44
	trace var x u foo
	while {$x < 100} {
	    error "Nested error"
	}
    }
    set fooMsg "foo not called"
    list [catch tproc msg] $msg $::errorInfo $fooMsg
} {1 {Nested error} {Nested error
    while executing
"error "Nested error""
    (procedure "tproc" line 5)
    invoked from within
"tproc"} {foo was called: x {} u}}

................................................................................
proc tproc code {
    return -code $code abc
}
test proc-old-7.1 {return with special completion code} {
    list [catch {tproc ok} msg] $msg
} {0 abc}
test proc-old-7.2 {return with special completion code} {
    list [catch {tproc error} msg] $msg $::errorInfo $::errorCode
} {1 abc {abc
    while executing
"tproc error"} NONE}
test proc-old-7.3 {return with special completion code} {
    list [catch {tproc return} msg] $msg
} {2 abc}
test proc-old-7.4 {return with special completion code} {
................................................................................
} {1 {}}
test proc-old-7.11 {return with special completion code} {
    proc tproc2 {} {
	global errorCode errorInfo
	catch {open _bad_file_name r} msg
	return -code error -errorinfo $errorInfo -errorcode $errorCode $msg
    }
    set msg [list [catch tproc2 msg] $msg $::errorInfo $::errorCode]
    regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
    normalizeMsg $msg
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
    while executing
"open _bad_file_name r"
    invoked from within
"tproc2"} {posix enoent {no such file or directory}}}
test proc-old-7.12 {return with special completion code} {
    proc tproc2 {} {
	global errorCode errorInfo
	catch {open _bad_file_name r} msg
	return -code error -errorcode $errorCode $msg
    }
    set msg [list [catch tproc2 msg] $msg $::errorInfo $::errorCode]
    regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
    normalizeMsg $msg
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
    while executing
"tproc2"} {posix enoent {no such file or directory}}}
test proc-old-7.13 {return with special completion code} {
    proc tproc2 {} {
	global errorCode errorInfo
	catch {open _bad_file_name r} msg
	return -code error -errorinfo $errorInfo $msg
    }
    set msg [list [catch tproc2 msg] $msg $::errorInfo $::errorCode]
    regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
    normalizeMsg $msg
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
    while executing
"open _bad_file_name r"
    invoked from within
"tproc2"} none}
test proc-old-7.14 {return with special completion code} {
    proc tproc2 {} {
	global errorCode errorInfo
	catch {open _bad_file_name r} msg
	return -code error $msg
    }
    set msg [list [catch tproc2 msg] $msg $::errorInfo $::errorCode]
    regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
    normalizeMsg $msg
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
    while executing
"tproc2"} none}
test proc-old-7.15 {return with special completion code} {
    list [catch {return -badOption foo message} msg] $msg

Changes to tests/set.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
...
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
...
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
...
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: set.test,v 1.10 2006/02/09 17:34:42 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

catch {unset x}
................................................................................
    }
    p
} [lsort {hej x $a x,hej x,x c(x ww a:x hej,1,hej hug {a a} {x ,ugg,hej} x,h"ej
{b c} foo 51}]; # " just a matching end quote

test set-2.1 {set command: runtime error, bad variable name} {
    unset -nocomplain {"foo}
    list [catch {set {"foo}} msg] $msg $errorInfo
} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable
    while executing
"set {"foo}"}}
test set-2.2 {set command: runtime error, not array variable} {
    catch {unset b}
    set b 44
    list [catch {set b(123)} msg] $msg
................................................................................
    set a(6) 44
    list [catch {set a(18)} msg] $msg
} {1 {can't read "a(18)": no such element in array}}
test set-2.4 {set command: runtime error, readonly variable} -body {
    proc readonly args {error "variable is read-only"}
    set x 123
    trace var x w readonly
    list [catch {set x 1} msg] $msg $errorInfo
} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
    while executing
*
"set x 1"}}
test set-2.5 {set command: runtime error, basic array operations} {
    list [catch {set a(other)} msg] $msg
} {1 {can't read "a(other)": no such element in array}}
................................................................................
    catch {$z i 20 30} msg
    $z msg
} {wrong # args: should be "set varName ?newValue?"}

test set-4.1 {uncompiled set command: runtime error, bad variable name} {
    unset -nocomplain {"foo}
    set z set
    list [catch {$z {"foo}} msg] $msg $errorInfo
} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable
    while executing
"$z {"foo}"}}
test set-4.2 {uncompiled set command: runtime error, not array variable} {
    set z set
    catch {unset b}
    $z b 44
................................................................................
    list [catch {$z a(18)} msg] $msg
} {1 {can't read "a(18)": no such element in array}}
test set-4.4 {uncompiled set command: runtime error, readonly variable} -body {
    set z set
    proc readonly args {error "variable is read-only"}
    $z x 123
    trace var x w readonly
    list [catch {$z x 1} msg] $msg $errorInfo
} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
    while executing
*
"$z x 1"}}
test set-4.5 {uncompiled set command: runtime error, basic array operations} {
    set z set
    list [catch {$z a(other)} msg] $msg






|







 







|







 







|







 







|







 







|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
...
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
...
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
...
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: set.test,v 1.11 2006/10/09 19:15:45 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

catch {unset x}
................................................................................
    }
    p
} [lsort {hej x $a x,hej x,x c(x ww a:x hej,1,hej hug {a a} {x ,ugg,hej} x,h"ej
{b c} foo 51}]; # " just a matching end quote

test set-2.1 {set command: runtime error, bad variable name} {
    unset -nocomplain {"foo}
    list [catch {set {"foo}} msg] $msg $::errorInfo
} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable
    while executing
"set {"foo}"}}
test set-2.2 {set command: runtime error, not array variable} {
    catch {unset b}
    set b 44
    list [catch {set b(123)} msg] $msg
................................................................................
    set a(6) 44
    list [catch {set a(18)} msg] $msg
} {1 {can't read "a(18)": no such element in array}}
test set-2.4 {set command: runtime error, readonly variable} -body {
    proc readonly args {error "variable is read-only"}
    set x 123
    trace var x w readonly
    list [catch {set x 1} msg] $msg $::errorInfo
} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
    while executing
*
"set x 1"}}
test set-2.5 {set command: runtime error, basic array operations} {
    list [catch {set a(other)} msg] $msg
} {1 {can't read "a(other)": no such element in array}}
................................................................................
    catch {$z i 20 30} msg
    $z msg
} {wrong # args: should be "set varName ?newValue?"}

test set-4.1 {uncompiled set command: runtime error, bad variable name} {
    unset -nocomplain {"foo}
    set z set
    list [catch {$z {"foo}} msg] $msg $::errorInfo
} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable
    while executing
"$z {"foo}"}}
test set-4.2 {uncompiled set command: runtime error, not array variable} {
    set z set
    catch {unset b}
    $z b 44
................................................................................
    list [catch {$z a(18)} msg] $msg
} {1 {can't read "a(18)": no such element in array}}
test set-4.4 {uncompiled set command: runtime error, readonly variable} -body {
    set z set
    proc readonly args {error "variable is read-only"}
    $z x 123
    trace var x w readonly
    list [catch {$z x 1} msg] $msg $::errorInfo
} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
    while executing
*
"$z x 1"}}
test set-4.5 {uncompiled set command: runtime error, basic array operations} {
    set z set
    list [catch {$z a(other)} msg] $msg

Changes to tests/switch.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
...
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: switch.test,v 1.15 2005/12/02 17:34:03 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test switch-1.1 {simple patterns} {
................................................................................

test switch-3.18 {-exact vs. -glob vs. -regexp} {
    list [catch {switch -regexp -glob Foo Foo {set result OK}} msg] $msg
} {1 {bad option "-glob": -regexp option already found}}

test switch-4.1 {error in executed command} {
    list [catch {switch a a {error "Just a test"} default {format 1}} msg] \
	    $msg $errorInfo
} {1 {Just a test} {Just a test
    while executing
"error "Just a test""
    ("a" arm line 1)
    invoked from within
"switch a a {error "Just a test"} default {format 1}"}}
test switch-4.2 {error: not enough args} {
................................................................................
    list [catch {switch a b} msg] $msg
} {1 {extra switch pattern with no body}}
test switch-4.4 {error: pattern with no body} {
    list [catch {switch a b {format 1} c} msg] $msg
} {1 {extra switch pattern with no body}}
test switch-4.5 {error in default command} {
    list [catch {switch foo a {error switch1} b {error switch 3} \
	    default {error switch2}} msg] $msg $errorInfo
} {1 switch2 {switch2
    while executing
"error switch2"
    ("default" arm line 1)
    invoked from within
"switch foo a {error switch1} b {error switch 3}  default {error switch2}"}}







|







 







|







 







|







7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
...
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: switch.test,v 1.16 2006/10/09 19:15:45 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test switch-1.1 {simple patterns} {
................................................................................

test switch-3.18 {-exact vs. -glob vs. -regexp} {
    list [catch {switch -regexp -glob Foo Foo {set result OK}} msg] $msg
} {1 {bad option "-glob": -regexp option already found}}

test switch-4.1 {error in executed command} {
    list [catch {switch a a {error "Just a test"} default {format 1}} msg] \
	    $msg $::errorInfo
} {1 {Just a test} {Just a test
    while executing
"error "Just a test""
    ("a" arm line 1)
    invoked from within
"switch a a {error "Just a test"} default {format 1}"}}
test switch-4.2 {error: not enough args} {
................................................................................
    list [catch {switch a b} msg] $msg
} {1 {extra switch pattern with no body}}
test switch-4.4 {error: pattern with no body} {
    list [catch {switch a b {format 1} c} msg] $msg
} {1 {extra switch pattern with no body}}
test switch-4.5 {error in default command} {
    list [catch {switch foo a {error switch1} b {error switch 3} \
	    default {error switch2}} msg] $msg $::errorInfo
} {1 switch2 {switch2
    while executing
"error switch2"
    ("default" arm line 1)
    invoked from within
"switch foo a {error switch1} b {error switch 3}  default {error switch2}"}}

Changes to tests/tcltest.test.

2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
...
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
...
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
...
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
....
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
....
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
# 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. 
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
# RCS: @(#) $Id: tcltest.test,v 1.53 2006/03/18 18:15:13 vincentdarley Exp $

# Note that there are several places where the value of 
# tcltest::currentFailure is stored/reset in the -setup/-cleanup
# of a test that has a body that runs [test] that will fail.
# This is a workaround of using the same tcltest code that we are
# testing to run the test itself.  Ditto on things like [verbose].
#
................................................................................
	set ::tcltest::outputChannel stdout
    }
    -body {
	outputChannel
    }
    -result {stdout}
    -cleanup {
	set tcltest::outputChannel $of
    }
}

test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} {
    -setup {
	set ef [makeFile {} efile]
	set of [outputFile]
................................................................................
# Test non-writeable directories, non-readable directories with directory flags
set notReadableDir [file join [temporaryDirectory] notreadable]
set notWriteableDir [file join [temporaryDirectory] notwriteable]

makeDirectory notreadable
makeDirectory notwriteable

switch -- $tcl_platform(platform) {
    "unix" {
	file attributes $notReadableDir -permissions 00333
	file attributes $notWriteableDir -permissions 00555
    }
    default {
	catch {file attributes $notWriteableDir -readonly 1}
	catch {testchmod 000 $notWriteableDir}
................................................................................
	set ::tcltest::workingDirectory $old
	cd $current
    }
}

# clean up from directory testing

switch $tcl_platform(platform) {
    "unix" {
	file attributes $notReadableDir -permissions 777
	file attributes $notWriteableDir -permissions 777
    }
    default {
	catch {file attributes $notWriteableDir -readonly 0}
    }
................................................................................
	set ::tcltest::currentFailure $fail
	verbose $v
} -match glob -output {*generated error; Return code was: 1*}

test tcltest-26.1 {Bug/RFE 1017151} -setup {
    makeFile {
	package require tcltest
	set errorInfo "Should never see this"
	tcltest::test tcltest-26.1.0 {
	    no errorInfo when only return code mismatch
	} -body {
	    set x 1
	} -returnCodes error -result 1
	tcltest::cleanupTests
    } test.tcl
................................................................................
} -match glob -result {*
---- Return code should have been one of: 1
==== tcltest-26.1.0 FAILED*}

test tcltest-26.2 {Bug/RFE 1017151} -setup {
    makeFile {
	package require tcltest
	set errorInfo "Should never see this"
	tcltest::test tcltest-26.2.0 {do not mask body errorInfo} -body {
	    error "body error"
	} -cleanup {
	    error "cleanup error"
	} -result 1
	tcltest::cleanupTests
    } test.tcl






|







 







|







 







|







 







|







 







|







 







|







2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
...
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
...
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
...
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
....
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
....
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
# 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. 
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
# RCS: @(#) $Id: tcltest.test,v 1.54 2006/10/09 19:15:45 msofer Exp $

# Note that there are several places where the value of 
# tcltest::currentFailure is stored/reset in the -setup/-cleanup
# of a test that has a body that runs [test] that will fail.
# This is a workaround of using the same tcltest code that we are
# testing to run the test itself.  Ditto on things like [verbose].
#
................................................................................
	set ::tcltest::outputChannel stdout
    }
    -body {
	outputChannel
    }
    -result {stdout}
    -cleanup {
	set ::tcltest::outputChannel $of
    }
}

test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} {
    -setup {
	set ef [makeFile {} efile]
	set of [outputFile]
................................................................................
# Test non-writeable directories, non-readable directories with directory flags
set notReadableDir [file join [temporaryDirectory] notreadable]
set notWriteableDir [file join [temporaryDirectory] notwriteable]

makeDirectory notreadable
makeDirectory notwriteable

switch -- $::tcl_platform(platform) {
    "unix" {
	file attributes $notReadableDir -permissions 00333
	file attributes $notWriteableDir -permissions 00555
    }
    default {
	catch {file attributes $notWriteableDir -readonly 1}
	catch {testchmod 000 $notWriteableDir}
................................................................................
	set ::tcltest::workingDirectory $old
	cd $current
    }
}

# clean up from directory testing

switch $::tcl_platform(platform) {
    "unix" {
	file attributes $notReadableDir -permissions 777
	file attributes $notWriteableDir -permissions 777
    }
    default {
	catch {file attributes $notWriteableDir -readonly 0}
    }
................................................................................
	set ::tcltest::currentFailure $fail
	verbose $v
} -match glob -output {*generated error; Return code was: 1*}

test tcltest-26.1 {Bug/RFE 1017151} -setup {
    makeFile {
	package require tcltest
	set ::errorInfo "Should never see this"
	tcltest::test tcltest-26.1.0 {
	    no errorInfo when only return code mismatch
	} -body {
	    set x 1
	} -returnCodes error -result 1
	tcltest::cleanupTests
    } test.tcl
................................................................................
} -match glob -result {*
---- Return code should have been one of: 1
==== tcltest-26.1.0 FAILED*}

test tcltest-26.2 {Bug/RFE 1017151} -setup {
    makeFile {
	package require tcltest
	set ::errorInfo "Should never see this"
	tcltest::test tcltest-26.2.0 {do not mask body errorInfo} -body {
	    error "body error"
	} -cleanup {
	    error "cleanup error"
	} -result 1
	tcltest::cleanupTests
    } test.tcl

Changes to tests/thread.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
#
# 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.14 2004/10/25 20:24:14 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Some tests require the testthread command
................................................................................
} {1 1 2}
test thread-4.3 {TclThreadSend preserve errorInfo} {testthread} {
    threadReap
    set len [llength [testthread names]]
    set serverthread [testthread create]
    set x [catch {testthread send $serverthread {set undef}} msg]
    threadReap
    list $len $x $msg $errorInfo
} {1 1 {can't read "undef": no such variable} {can't read "undef": no such variable
    while executing
"set undef"
    invoked from within
"testthread send $serverthread {set undef}"}}
test thread-4.4 {TclThreadSend preserve code} {testthread} {
    threadReap
    set len [llength [testthread names]]
    set serverthread [testthread create]
    set x [catch {testthread send $serverthread {set errorInfo {}; break}} msg]
    threadReap
    list $len $x $msg $errorInfo
} {1 3 {} {}}
test thread-4.5 {TclThreadSend preserve errorCode} {testthread} {
    threadReap
    set ::tcltest::mainThread [testthread names]
    set serverthread [testthread create]
    set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg]
    threadReap
    list $x $msg $errorCode
} {1 ERR CODE}


test thread-5.0 {Joining threads} {testthread} {
    threadReap
    set serverthread [testthread create -joinable]
    testthread send -async $serverthread {after 1000 ; testthread exit}






|







 







|









|

|







|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
#
# 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.15 2006/10/09 19:15:45 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Some tests require the testthread command
................................................................................
} {1 1 2}
test thread-4.3 {TclThreadSend preserve errorInfo} {testthread} {
    threadReap
    set len [llength [testthread names]]
    set serverthread [testthread create]
    set x [catch {testthread send $serverthread {set undef}} msg]
    threadReap
    list $len $x $msg $::errorInfo
} {1 1 {can't read "undef": no such variable} {can't read "undef": no such variable
    while executing
"set undef"
    invoked from within
"testthread send $serverthread {set undef}"}}
test thread-4.4 {TclThreadSend preserve code} {testthread} {
    threadReap
    set len [llength [testthread names]]
    set serverthread [testthread create]
    set x [catch {testthread send $serverthread {set ::errorInfo {}; break}} msg]
    threadReap
    list $len $x $msg $::errorInfo
} {1 3 {} {}}
test thread-4.5 {TclThreadSend preserve errorCode} {testthread} {
    threadReap
    set ::tcltest::mainThread [testthread names]
    set serverthread [testthread create]
    set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg]
    threadReap
    list $x $msg $::errorCode
} {1 ERR CODE}


test thread-5.0 {Joining threads} {testthread} {
    threadReap
    set serverthread [testthread create -joinable]
    testthread send -async $serverthread {after 1000 ; testthread exit}

Changes to tests/var.test.

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: var.test,v 1.26 2004/09/30 23:06:49 dgp Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.2
    namespace import -force ::tcltest::*
}

................................................................................
    #
    namespace eval test A useSomeUnlikelyNameHere
    namespace eval test unset useSomeUnlikelyNameHere
} {}


test var-16.1 {CallVarTraces: save/restore interp error state} {
    trace add variable errorCode write { ;#}
    catch {error foo bar baz}
    trace remove variable errorCode write { ;#}
    set errorInfo
} bar

catch {namespace delete ns}
catch {unset arr}
catch {unset v}

catch {rename p ""}






|







 







|

|
|







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: var.test,v 1.27 2006/10/09 19:15:45 msofer Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.2
    namespace import -force ::tcltest::*
}

................................................................................
    #
    namespace eval test A useSomeUnlikelyNameHere
    namespace eval test unset useSomeUnlikelyNameHere
} {}


test var-16.1 {CallVarTraces: save/restore interp error state} {
    trace add variable ::errorCode write { ;#}
    catch {error foo bar baz}
    trace remove variable ::errorCode write { ;#}
    set ::errorInfo
} bar

catch {namespace delete ns}
catch {unset arr}
catch {unset v}

catch {rename p ""}

Changes to tests/while-old.test.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: while-old.test,v 1.7 2004/05/19 13:06:15 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test while-old-1.1 {basic while loops} {
................................................................................
    catch {unset x}
    set x 1
    set err [catch {while {$x} {set x foo}} msg]
    list $err $msg
} {1 {expected boolean value but got "foo"}}
test while-old-4.6 {errors in while loops} {
    set err [catch {while {1} {error "loop aborted"}} msg]
    list $err $msg $errorInfo
} {1 {loop aborted} {loop aborted
    while executing
"error "loop aborted""}}

test while-old-5.1 {while return result} {
    while {0} {set a 400}
} {}






|







 







|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: while-old.test,v 1.8 2006/10/09 19:15:45 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test while-old-1.1 {basic while loops} {
................................................................................
    catch {unset x}
    set x 1
    set err [catch {while {$x} {set x foo}} msg]
    list $err $msg
} {1 {expected boolean value but got "foo"}}
test while-old-4.6 {errors in while loops} {
    set err [catch {while {1} {error "loop aborted"}} msg]
    list $err $msg $::errorInfo
} {1 {loop aborted} {loop aborted
    while executing
"error "loop aborted""}}

test while-old-5.1 {while return result} {
    while {0} {set a 400}
} {}

Changes to tests/while.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
..
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
...
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
...
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: while.test,v 1.12 2006/08/22 18:10:44 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Basic "while" operation.
................................................................................
test while-1.1 {TclCompileWhileCmd: missing test expression} {
    catch {while } msg
    set msg
} {wrong # args: should be "while test command"}
test while-1.2 {TclCompileWhileCmd: error in test expression} -body {
    set i 0
    catch {while {$i<} break} msg
    set errorInfo
} -match glob -result {*"while {$i<} break"}
test while-1.3 {TclCompileWhileCmd: error in test expression} {
    set err [catch {while {"a"+"b"} {error "loop aborted"}} msg]
    list $err $msg
} {1 {can't use non-numeric string as operand of "+"}}
test while-1.4 {TclCompileWhileCmd: multiline test expr} {
    set value 1
................................................................................
    set i 0
    catch {while {$i < 5} } msg
    set msg
} {wrong # args: should be "while test command"}
test while-1.8 {TclCompileWhileCmd: error compiling command body} -body {
    set i 0
    catch {while {$i < 5} {set}} msg
    set errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
test while-1.9 {TclCompileWhileCmd: simple command body} {
    set a {}
    set i 1
    while {$i<6} {
................................................................................
    catch {$z } msg
    set msg
} {wrong # args: should be "while test command"}
test while-4.3 {while (not compiled): error in test expression} -body {
    set i 0
    set z while
    catch {$z {$i<} {set x 1}} msg
    set errorInfo
} -match glob -result {*"$z {$i<} {set x 1}"}
test while-4.4 {while (not compiled): error in test expression} {
    set z while
    set err [catch {$z {"a"+"b"} {error "loop aborted"}} msg]
    list $err $msg
} {1 {can't use non-numeric string as operand of "+"}}
test while-4.5 {while (not compiled): multiline test expr} {
................................................................................
    catch {$z {$i < 5} } msg
    set msg
} {wrong # args: should be "while test command"}
test while-4.9 {while (not compiled): error compiling command body} -body {
    set i 0
    set z while
    catch {$z {$i < 5} {set}} msg
    set errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"
    ("while" body line 1)
    invoked from within
"$z {$i < 5} {set}"}
test while-4.10 {while (not compiled): simple command body} {






|







 







|







 







|







 







|







 







|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
..
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
...
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
...
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: while.test,v 1.13 2006/10/09 19:15:45 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Basic "while" operation.
................................................................................
test while-1.1 {TclCompileWhileCmd: missing test expression} {
    catch {while } msg
    set msg
} {wrong # args: should be "while test command"}
test while-1.2 {TclCompileWhileCmd: error in test expression} -body {
    set i 0
    catch {while {$i<} break} msg
    set ::errorInfo
} -match glob -result {*"while {$i<} break"}
test while-1.3 {TclCompileWhileCmd: error in test expression} {
    set err [catch {while {"a"+"b"} {error "loop aborted"}} msg]
    list $err $msg
} {1 {can't use non-numeric string as operand of "+"}}
test while-1.4 {TclCompileWhileCmd: multiline test expr} {
    set value 1
................................................................................
    set i 0
    catch {while {$i < 5} } msg
    set msg
} {wrong # args: should be "while test command"}
test while-1.8 {TclCompileWhileCmd: error compiling command body} -body {
    set i 0
    catch {while {$i < 5} {set}} msg
    set ::errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"*}
test while-1.9 {TclCompileWhileCmd: simple command body} {
    set a {}
    set i 1
    while {$i<6} {
................................................................................
    catch {$z } msg
    set msg
} {wrong # args: should be "while test command"}
test while-4.3 {while (not compiled): error in test expression} -body {
    set i 0
    set z while
    catch {$z {$i<} {set x 1}} msg
    set ::errorInfo
} -match glob -result {*"$z {$i<} {set x 1}"}
test while-4.4 {while (not compiled): error in test expression} {
    set z while
    set err [catch {$z {"a"+"b"} {error "loop aborted"}} msg]
    list $err $msg
} {1 {can't use non-numeric string as operand of "+"}}
test while-4.5 {while (not compiled): multiline test expr} {
................................................................................
    catch {$z {$i < 5} } msg
    set msg
} {wrong # args: should be "while test command"}
test while-4.9 {while (not compiled): error compiling command body} -body {
    set i 0
    set z while
    catch {$z {$i < 5} {set}} msg
    set ::errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
    while *ing
"set"
    ("while" body line 1)
    invoked from within
"$z {$i < 5} {set}"}
test while-4.10 {while (not compiled): simple command body} {