Tcl Source Code

Check-in [92c423cb2e]
Login

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

Overview
Comment:* tests/expr.test: * tests/for-old.test: * tests/for.test: * tests/foreach.test: * tests/format.test: * tests/httpold.test: * tests/if.test: * tests/init.test: * tests/interp.test: * tests/while.test: Added some tests for known bugs (marked with knownBug constraint), and cleaned up a few bad tests.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-1-branch-old
Files: files | file ages | folders
SHA1:92c423cb2e3b2fdc52edd70710f2366bd5fba591
User & Date: stanton 1999-04-02 23:44:37
Context
1999-04-02
23:44
* generic/regc_locale.c: * generic/regcustom.h: * generic/tcl.decls: * generic/tclCmdIL.c: * generic... check-in: de06484e63 user: stanton tags: core-8-1-branch-old
23:44
* tests/expr.test: * tests/for-old.test: * tests/for.test: * tests/foreach.test: * tests/format.test... check-in: 92c423cb2e user: stanton tags: core-8-1-branch-old
22:30
safe-6.3 now passes on Windows and Unix for both release and debug. This addresses item 81 on the wh... check-in: 8c40033f93 user: hershey tags: core-8-1-branch-old
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to tests/expr.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
663
664
665
666
667
668
669
670
671
672
673
674






















675
676









677
678
679
680
681
682
683
684
685




#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: expr.test,v 1.1.2.5 1999/03/24 02:49:08 hershey Exp $

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

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    set gotT1 0
................................................................................
        set x  [expr $x+$f+$center]
        set x  [expr $x+$f+$center]
        set y  [expr round($x)]
    }
    p
} 3

# cleanup
unset a
::tcltest::cleanupTests
return





















































|







 







|
<
<
<

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

<
<
<
<
<
<
<
<
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
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
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705








706
707
708
709
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: expr.test,v 1.1.2.6 1999/04/02 23:44:37 stanton Exp $

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

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    set gotT1 0
................................................................................
        set x  [expr $x+$f+$center]
        set x  [expr $x+$f+$center]
        set y  [expr round($x)]
    }
    p
} 3

# Test for incorrect "double evaluation" semantics




test expr-20.1 {wrong brace matching} {
    catch {unset l}
    catch {unset r}
    catch {unset q}
    catch {unset cmd}
    catch {unset a}
    set l "\{"; set r "\}"; set q "\""
    set cmd "expr $l$q|$q == $q$r$q$r"
    list [catch $cmd a] $a
} {1 {extra characters after close-brace}}
test expr-20.2 {double invocation of variable traces} {knownBug} {
    set exprtracecounter 0
    proc exprtraceproc {args} {
       upvar #0 exprtracecounter counter
       set argc [llength $args]
       set extraargs [lrange $args 0 [expr {$argc - 4}]]
       set name [lindex $args [expr {$argc - 3}]]
       upvar 1 $name var
       if {[incr counter] % 2 == 1} {
           set var "$counter oops [concat $extraargs]"
       } else {
           set var "$counter + [concat $extraargs]"
       }
    }
    trace variable exprtracevar r [list exprtraceproc 10]
    list [catch {expr "$exprtracevar + 20"} a] $a \
        [catch {expr "$exprtracevar + 20"} b] $b \
        [unset exprtracevar exprtracecounter]
} {1 {syntax error in expression "1 oops 10 + 20"} 0 32 {}}
test expr-20.3 {broken substitution of integer digits} {
    # fails with 8.0.x, but not 8.1b2
    list [set a 000; expr 0x1$a] [set a 1; expr ${a}000]
} {4096 1000}









# cleanup
unset a
::tcltest::cleanupTests
return

Changes to tests/for-old.test.

8
9
10
11
12
13
14
15
16
17


18
19
20
21
22
23
24
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for-old.test,v 1.1.2.5 1999/03/24 02:49:09 hershey Exp $

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



# Check "for" and its use of continue and break.

catch {unset a i}
test for-old-1.1 {for tests} {
    set a {}
    for {set i 1} {$i<6} {set i [expr $i+1]} {






|

|
>
>







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for-old.test,v 1.1.2.6 1999/04/02 23:44:38 stanton Exp $

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

# Check "for" and its use of continue and break.

catch {unset a i}
test for-old-1.1 {for tests} {
    set a {}
    for {set i 1} {$i<6} {set i [expr $i+1]} {

Changes to tests/for.test.

5
6
7
8
9
10
11
12
13
14


15
16
17
18
19
20
21
...
708
709
710
711
712
713
714




















715
716
717
718
719
720
721
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for.test,v 1.1.2.5 1999/03/24 02:49:10 hershey Exp $

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



# Basic "for" operation.

test for-1.1 {TclCompileForCmd: missing initial command} {
    list [catch {for} msg] $msg
} {1 {wrong # args: should be "for start test next command"}}
test for-1.2 {TclCompileForCmd: error in initial command} {
................................................................................
    set a
} {}
test for-5.15 {for cmd with computed command names: for command result} {
    set z for
    set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}]
    set a
} {}





















# cleanup
::tcltest::cleanupTests
return









|

|
>
>







 







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







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for.test,v 1.1.2.6 1999/04/02 23:44:38 stanton Exp $

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

# 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} {
................................................................................
    set a
} {}
test for-5.15 {for cmd with computed command names: for command result} {
    set z for
    set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}]
    set a
} {}

# Test for incorrect "double evaluation" semantics

test for-6.1 {possible delayed substitution of increment command} {knownBug} {
    # Increment should be 5, and lappend should always append 5
    catch {unset a}
    catch {unset i}
    set a 5
    set i {}
    for {set a 1} {$a < 12} "incr a $a" {lappend i $a}
    set i
} {1 6 11}

test for-6.2 {possible delayed substitution of body command} {knownBug} {
    # Increment should be 5, and lappend should always append 5
    set a 5
    set i {}
    for {set a 1} {$a < 12} {incr a $a} "lappend i $a"
    set i
} {5 5 5 5}

# cleanup
::tcltest::cleanupTests
return



Changes to tests/foreach.test.

6
7
8
9
10
11
12
13
14
15


16
17
18
19
20
21
22
...
203
204
205
206
207
208
209













210
211
212
213
214
215
216
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: foreach.test,v 1.1.2.5 1999/03/24 02:49:11 hershey Exp $

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



catch {unset a}
catch {unset x}

# Basic "foreach" operation.

test foreach-1.1 {basic foreach tests} {
................................................................................
    set a
} {a b}
test foreach-5.3 {break tests} {catch {break foo} msg} 1
test foreach-5.4 {break tests} {
    catch {break foo} msg
    set msg
} {wrong # args: should be "break"}














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







|

|
>
>







 







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







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: foreach.test,v 1.1.2.6 1999/04/02 23:44:38 stanton Exp $

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

catch {unset a}
catch {unset x}

# Basic "foreach" operation.

test foreach-1.1 {basic foreach tests} {
................................................................................
    set a
} {a b}
test foreach-5.3 {break tests} {catch {break foo} msg} 1
test foreach-5.4 {break tests} {
    catch {break foo} msg
    set msg
} {wrong # args: should be "break"}

# Test for incorrect "double evaluation" semantics

test foreach-6.1 {delayed substitution of body} {knownBug} {
    proc foo {} {
       set a 0
       foreach a [list 1 2 3] "
           set x $a
       "
       set x
    }
    foo
} {0}

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

Changes to tests/format.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: format.test,v 1.1.2.6 1999/03/24 02:49:11 hershey Exp $

if {[info commands test] != "test"} {
    source defs
}

# The following code is needed because some versions of SCO Unix have
# a round-off error in sprintf which would cause some of the tests to
# fail.  Someday I hope this code shouldn't be necessary (code added
# 9/9/91).







|

|
|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: format.test,v 1.1.2.7 1999/04/02 23:44:38 stanton Exp $

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

# The following code is needed because some versions of SCO Unix have
# a round-off error in sprintf which would cause some of the tests to
# fail.  Someday I hope this code shouldn't be necessary (code added
# 9/9/91).

Changes to tests/httpold.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
385
386
387
388
389
390
391

392
393

394
395
396
397
398
399
400
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: httpold.test,v 1.1.2.6 1999/03/26 19:14:01 hershey Exp $

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

if {[catch {package require http 1.0}]} {
    if {[info exist httpold]} {
................................................................................
test http-4.11 {httpEvent} {
    set token [http_get $url -timeout 1 -command {#}]
    http_reset $token
    http_status $token
} {reset}
test http-4.12 {httpEvent} {
    update

    set token [http_get $url -timeout 1 -command {#}]
    update

    http_status $token
} {timeout}

test http-5.1 {http_formatQuery} {
    http_formatQuery name1 value1 name2 "value two"
} {name1=value1&name2=value+two}







|







 







>

<
>







7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
385
386
387
388
389
390
391
392
393

394
395
396
397
398
399
400
401
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: httpold.test,v 1.1.2.7 1999/04/02 23:44:38 stanton Exp $

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

if {[catch {package require http 1.0}]} {
    if {[info exist httpold]} {
................................................................................
test http-4.11 {httpEvent} {
    set token [http_get $url -timeout 1 -command {#}]
    http_reset $token
    http_status $token
} {reset}
test http-4.12 {httpEvent} {
    update
    after 1000 {set x 1}
    set token [http_get $url -timeout 1 -command {#}]

    vwait x
    http_status $token
} {timeout}

test http-5.1 {http_formatQuery} {
    http_formatQuery name1 value1 name2 "value two"
} {name1=value1&name2=value+two}

Changes to tests/if.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
499
500
501
502
503
504
505

506
507
508
509
510
511
512
....
1005
1006
1007
1008
1009
1010
1011
































































1012
1013
1014
1015
1016
1017
1018
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: if.test,v 1.1.2.6 1999/03/24 02:49:14 hershey Exp $

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

# Basic "if" operation.

................................................................................
# Check "if" and computed command names.

catch {unset a}
test if-5.1 {if cmd with computed command names: missing if/elseif test} {
    set z if
    list [catch {$z} msg] $msg
} {1 {wrong # args: no expression after "if" argument}}

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} {
    set z if
    list [catch {$z {1+}} msg] $msg $errorInfo
................................................................................
    $z 0 then {set a 22; concat abc} elseif 1 {concat def} {concat ghi}
} def

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

































































# cleanup
::tcltest::cleanupTests
return










|







 







>







 







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







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
....
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
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: if.test,v 1.1.2.7 1999/04/02 23:44:38 stanton Exp $

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

# Basic "if" operation.

................................................................................
# Check "if" and computed command names.

catch {unset a}
test if-5.1 {if cmd with computed command names: missing if/elseif test} {
    set z if
    list [catch {$z} msg] $msg
} {1 {wrong # args: no expression after "if" argument}}

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} {
    set z if
    list [catch {$z {1+}} msg] $msg $errorInfo
................................................................................
    $z 0 then {set a 22; concat abc} elseif 1 {concat def} {concat ghi}
} def

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

# Test for incorrect "double evaluation semantics"

test if-10.1 {delayed substitution of then body} {knownBug} {
    set j 0
    if {[incr j] == 1} "
       set result $j
    "
    set result
} {0}
test if-10.2 {delayed substitution of elseif expression} {knownBug} {
    set j 0
    if {[incr j] == 0} {
       set result badthen
    } elseif "$j == 1" {
       set result badelseif
    } else {
       set result ok
    }
    set result
} {ok}
test if-10.3 {delayed substitution of elseif body} {knownBug} {
    set j 0
    if {[incr j] == 0} {
       set result badthen
    } elseif {1} "
       set result $j
    "
    set result
} {0}
test if-10.4 {delayed substitution of else body} {knownBug} {
    set j 0
    if {[incr j] == 0} {
       set result badthen
    } else "
       set result $j
    "
    set result
} {0}
test if-10.5 {substituted control words} {knownBug} {
    set then then; proc then {} {return badthen}
    set else else; proc else {} {return badelse}
    set elseif elseif; proc elseif {} {return badelseif}
    list [catch {if 1 $then {if 0 {} $elseif 1 {if 0 {} $else {list ok}}}} a] $a
} {0 ok}
test if-10.6 {double invocation of variable traces} {knownBug} {
    set iftracecounter 0
    proc iftraceproc {args} {
       upvar #0 iftracecounter counter
       set argc [llength $args]
       set extraargs [lrange $args 0 [expr {$argc - 4}]]
       set name [lindex $args [expr {$argc - 3}]]
       upvar 1 $name var
       if {[incr counter] % 2 == 1} {
           set var "$counter oops [concat $extraargs]"
       } else {
           set var "$counter + [concat $extraargs]"
       }
    }
    trace variable iftracevar r [list iftraceproc 10]
    list [catch {if "$iftracevar + 20" {}} a] $a \
        [catch {if "$iftracevar + 20" {}} b] $b \
        [unset iftracevar iftracecounter]
} {1 {syntax error in expression "1 oops 10 + 20"} 0 {} {}}

# cleanup
::tcltest::cleanupTests
return




Changes to tests/init.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
61
62
63
64
65
66
67
68


69
70
71
72
73
74
75
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: init.test,v 1.1.2.5 1999/03/24 02:49:17 hershey Exp $

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

# Clear out any namespaces called test_ns_*
catch {eval namespace delete [namespace children :: test_ns_*]}
................................................................................

set testInterp [interp create]
interp eval $testInterp [list set argv $argv]
interp eval $testInterp [list source [file join $::tcltest::testsDir defs.tcl]]

interp eval $testInterp {

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



auto_reset
catch {rename parray {}}

test init-2.0 {load parray - stage 1} {
    set ret [catch {namespace eval ::tcltest {parray}} error]
    rename parray {} ; # remove it, for the next test - that should not fail.






|







 







|
>
>







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: init.test,v 1.1.2.6 1999/04/02 23:44:39 stanton Exp $

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

# Clear out any namespaces called test_ns_*
catch {eval namespace delete [namespace children :: test_ns_*]}
................................................................................

set testInterp [interp create]
interp eval $testInterp [list set argv $argv]
interp eval $testInterp [list source [file join $::tcltest::testsDir defs.tcl]]

interp eval $testInterp {

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

auto_reset
catch {rename parray {}}

test init-2.0 {load parray - stage 1} {
    set ret [catch {namespace eval ::tcltest {parray}} error]
    rename parray {} ; # remove it, for the next test - that should not fail.

Changes to tests/interp.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
2340
2341
2342
2343
2344
2345
2346

2347
2348
2349
2350
2351
2352
2353
2354
2355
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: interp.test,v 1.1.2.9 1999/03/26 02:24:46 stanton Exp $

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

# The set of hidden commands is platform dependent:

................................................................................
	myNewSet a $value
	return $a
    }
    catch {unset a}
    set result [testMyNewSet "ok"]
    rename testMyNewSet {}
    rename mySet {}

    set result
} ok

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






|







 







>









6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
....
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: interp.test,v 1.1.2.10 1999/04/02 23:44:39 stanton Exp $

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

# The set of hidden commands is platform dependent:

................................................................................
	myNewSet a $value
	return $a
    }
    catch {unset a}
    set result [testMyNewSet "ok"]
    rename testMyNewSet {}
    rename mySet {}
    rename myNewSet {}
    set result
} ok

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

Changes to tests/while.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
38
39
40
41
...
600
601
602
603
604
605
606










607
608
609
610
611
612
613
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: while.test,v 1.1.2.5 1999/03/24 02:49:51 hershey Exp $

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

# Basic "while" operation.

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

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} {
    set i 0
    catch {while {$i<}} msg
    set errorInfo
} {wrong # args: should be "while test command"

    while compiling
"while {$i<}"}
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
    while {($tcl_platform(platform) != "foobar1") && \
................................................................................
	    catch {incr i -5} msg
	}
	set a [concat $a $i]
        incr i
    }
    set a
} {1 3}











# cleanup
::tcltest::cleanupTests
return









|







 







|

|
>

|







 







>
>
>
>
>
>
>
>
>
>







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
38
39
40
41
42
...
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: while.test,v 1.1.2.6 1999/04/02 23:44:39 stanton Exp $

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

# 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} {
    set i 0
    catch {while {$i<} break} msg
    set errorInfo
} {syntax error in expression "$i<"
    ("while" test expression)
    while compiling
"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
    while {($tcl_platform(platform) != "foobar1") && \
................................................................................
	    catch {incr i -5} msg
	}
	set a [concat $a $i]
        incr i
    }
    set a
} {1 3}

# Test for incorrect "double evaluation" semantics

test while-7.1 {delayed substitution of body} {knownBug} {
    set i 0
    while {[incr i] < 10} "
       set result $i
    "
    set result
} {0}

# cleanup
::tcltest::cleanupTests
return