diff options
author | Steve Bennett <steveb@workware.net.au> | 2010-01-24 11:49:28 +1000 |
---|---|---|
committer | Steve Bennett <steveb@workware.net.au> | 2010-10-15 11:02:42 +1000 |
commit | b367df9ca11f36a392b97afc2767694f8bfe1c4f (patch) | |
tree | b61a231c02622789cadaee3f3ed7c824d2a221d1 /tests | |
parent | fb44f9ee2d4b23bc4f5f46ad3b01b33e563932cd (diff) | |
download | jimtcl-b367df9ca11f36a392b97afc2767694f8bfe1c4f.zip jimtcl-b367df9ca11f36a392b97afc2767694f8bfe1c4f.tar.gz jimtcl-b367df9ca11f36a392b97afc2767694f8bfe1c4f.tar.bz2 |
Bugs, features, tests
Subst was broken for backslash escapes
Add support for return, break, continue in subst commands
Accept abbreviations for switches to subst
Fix 'list #'
More tests
Diffstat (limited to 'tests')
-rw-r--r-- | tests/Makefile | 6 | ||||
-rw-r--r-- | tests/for.test | 66 | ||||
-rw-r--r-- | tests/list.test | 111 | ||||
-rw-r--r-- | tests/perf.test | 6 | ||||
-rw-r--r-- | tests/subst.test | 163 | ||||
-rw-r--r-- | tests/tree.test | 6 | ||||
-rw-r--r-- | tests/uplevel.test | 112 | ||||
-rw-r--r-- | tests/while.test | 127 |
8 files changed, 589 insertions, 8 deletions
diff --git a/tests/Makefile b/tests/Makefile index a97f183..9ce5451 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -1,5 +1,7 @@ -test: ../jimsh - @for i in *.test; do ../jimsh $$i; done +JIMSH ?= ../jimsh + +test: $(JIMSH) + @for i in *.test; do $(JIMSH) $$i; done ../jimsh: ../*.c make -C .. all diff --git a/tests/for.test b/tests/for.test new file mode 100644 index 0000000..d3a136e --- /dev/null +++ b/tests/for.test @@ -0,0 +1,66 @@ +# Commands covered: for, continue, break +# +# This file contains the original set of tests for Tcl's for command. +# Since the for command is now compiled, a new set of tests covering +# the new implementation is in the file "for.test". Sourcing this file +# into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# 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.5 2000/04/10 17:18:59 ericm Exp $ + +source testing.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]} { + set a [concat $a $i] + } + set a +} {1 2 3 4 5} +test for-old-1.2 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==4 continue + set a [concat $a $i] + } + set a +} {1 2 3 5} +test for-old-1.3 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==4 break + set a [concat $a $i] + } + set a +} {1 2 3} +test for-old-1.4 {for tests} {catch {for 1 2 3} msg} 1 +test for-old-1.5 {for tests} { + catch {for 1 2 3} msg +} {1} +test for-old-1.6 {for tests} {catch {for 1 2 3 4 5} msg} 1 +test for-old-1.7 {for tests} { + catch {for 1 2 3 4 5} msg +} {1} +test for-old-1.8 {for tests} { + set a {xyz} + for {set i 1} {$i<6} {set i [expr $i+1]} {} + set a +} xyz +test for-old-1.9 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]; if $i==4 break} { + set a [concat $a $i] + } + set a +} {1 2 3} + +testreport diff --git a/tests/list.test b/tests/list.test new file mode 100644 index 0000000..b82a741 --- /dev/null +++ b/tests/list.test @@ -0,0 +1,111 @@ +# Commands covered: list +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 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: list.test,v 1.5 2000/04/10 17:19:01 ericm Exp $ + +source testing.tcl + +# First, a bunch of individual tests + +test list-1.1 {basic tests} {list a b c} {a b c} +test list-1.2 {basic tests} {list {a b} c} {{a b} c} +test list-1.3 {basic tests} {list \{a b c} {\{a b c} +test list-1.4 {basic tests} "list a{}} b{} c}" "a\\{\\}\\} b{} c\\}" +test list-1.5 {basic tests} {list a\[ b\] } "{a\[} b\\]" +test list-1.6 {basic tests} {list c\ d\t } "{c } {d\t}" +test list-1.7 {basic tests} {list e\n f\$ } "{e\n} {f\$}" +test list-1.8 {basic tests} {list g\; h\\} {{g;} h\\} +test list-1.9 {basic tests} "list a\\\[} b\\\]} " "a\\\[\\\} b\\\]\\\}" +test list-1.10 {basic tests} "list c\\\} d\\t} " "c\\} d\\t\\}" +test list-1.11 {basic tests} "list e\\n} f\\$} " "e\\n\\} f\\$\\}" +test list-1.12 {basic tests} "list g\\;} h\\\\} " "g\\;\\} {h\\}}" +test list-1.13 {basic tests} {list a {{}} b} {a {{}} b} +test list-1.14 {basic tests} {list a b xy\\} "a b xy\\\\" +test list-1.15 {basic tests} "list a b\} e\\" "a b\\} e\\\\" +test list-1.16 {basic tests} "list a b\}\\\$ e\\\$\\" "a b\\}\\\$ e\\\$\\\\" +test list-1.17 {basic tests} {list a\f \{\f} "{a\f} \\\{\\f" +test list-1.18 {basic tests} {list a\r \{\r} "{a\r} \\\{\\r" +test list-1.19 {basic tests} {list a\v \{\v} "{a\v} \\\{\\v" +test list-1.20 {basic tests} {list \"\}\{} "\\\"\\}\\{" +test list-1.21 {basic tests} {list a b c\\\nd} "a b c\\\\\\nd" +test list-1.22 {basic tests} {list "{ab}\\"} \\{ab\\}\\\\ +test list-1.23 {basic tests} {list \{} "\\{" +test list-1.24 {basic tests} {list} {} +test list-1.25 {basic tests} {list #} {{#}} + +# For the next round of tests create a list and then pick it apart +# with "index" to make sure that we get back exactly what went in. + +test list-2.1 {placeholder} { +} {} +set num 1 +proc lcheck {a b c} { + global num d + set d [list $a $b $c] +; test list-2.$num {what goes in must come out} {lindex $d 0} $a + set num [expr $num+1] +; test list-2.$num {what goes in must come out} {lindex $d 1} $b + set num [expr $num+1] +; test list-2.$num {what goes in must come out} {lindex $d 2} $c + set num [expr $num+1] +} +lcheck a b c +lcheck "a b" c\td e\nf +lcheck {{a b}} {} { } +lcheck \$ \$ab ab\$ +lcheck \; \;ab ab\; +lcheck \[ \[ab ab\[ +lcheck \\ \\ab ab\\ +lcheck {"} {"ab} {ab"} +lcheck {a b} { ab} {ab } +lcheck a{ a{b \{ab +lcheck a} a}b }ab +lcheck a\\} {a \}b} {a \{c} +lcheck xyz \\ 1\\\n2 +lcheck "{ab}\\" "{ab}xy" abc + +concat {} + +# Check that tclListObj.c's SetListFromAny handles possible overlarge +# string rep lengths in the source object. + +proc slowsort list { + set result {} + set last [expr [llength $list] - 1] + while {$last > 0} { + set minIndex [expr [llength $list] - 1] + set min [lindex $list $last] + set i [expr $minIndex-1] + while {$i >= 0} { + if {[string compare [lindex $list $i] $min] < 0} { + set minIndex $i + set min [lindex $list $i] + } + set i [expr $i-1] + } + set result [concat $result [list $min]] + if {$minIndex == 0} { + set list [lrange $list 1 end] + } else { + set list [concat [lrange $list 0 [expr $minIndex-1]] \ + [lrange $list [expr $minIndex+1] end]] + } + set last [expr $last-1] + } + return [concat $result $list] +} +test list-3.1 {SetListFromAny and lrange/concat results} { + slowsort {fred julie alex carol bill annie} +} {alex annie bill carol fred julie} + +testreport diff --git a/tests/perf.test b/tests/perf.test index 1cd231c..fd28dff 100644 --- a/tests/perf.test +++ b/tests/perf.test @@ -11,7 +11,7 @@ proc bench {name cmd} { } proc set_dict_sugar {} { - for {set i 0} {$i < 20000} {incr i} { + for {set i 0} {$i < 10000} {incr i} { set a(b) $i } } @@ -20,7 +20,7 @@ proc set_dict_sugar {} { # speedup since a($b) needs to be interpolated and reparsed every time proc set_var_dict_sugar {} { set b b - for {set i 0} {$i < 20000} {incr i} { + for {set i 0} {$i < 10000} {incr i} { set a($b) $i } } @@ -102,7 +102,7 @@ proc read_file_split_assign_lindex {file} { # Create a really big file set f [open test.in w] -for {set i 0} {$i < 50000} {incr i} { +for {set i 0} {$i < 10000} {incr i} { puts $f "a\tb\tc\te\tf\tg\th\ti\tj\tk" } close $f diff --git a/tests/subst.test b/tests/subst.test new file mode 100644 index 0000000..4f29c6d --- /dev/null +++ b/tests/subst.test @@ -0,0 +1,163 @@ +# Commands covered: subst +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-2000 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: subst.test,v 1.6.2.1 2001/04/03 22:54:38 hobbs Exp $ + +source testing.tcl + +test subst-1.0 {basics} { + subst {\$x} +} "\$x" + +test subst-1.1 {basics} { + list [catch {subst} msg] +} {1} +test subst-1.2 {basics} { + list [catch {subst a b c} msg] +} {1} + +test subst-2.1 {simple strings} { + subst {} +} {} +test subst-2.2 {simple strings} { + subst a +} a +test subst-2.3 {simple strings} { + subst abcdefg +} abcdefg + +test subst-3.1 {backslash substitutions} { + subst {\x\$x\[foo bar]\\} +} "x\$x\[foo bar]\\" + +test subst-4.1 {variable substitutions} { + set a 44 + subst {$a} +} {44} +test subst-4.2 {variable substitutions} { + set a 44 + subst {x$a.y{$a}.z} +} {x44.y{44}.z} +test subst-4.3 {variable substitutions} { + catch {unset a} + set a(13) 82 + set i 13 + subst {x.$a($i)} +} {x.82} +catch {unset a} +set long {This is a very long string, intentionally made so long that it + will overflow the static character size for dstrings, so that + additional memory will have to be allocated by subst. That way, + if the subst procedure forgets to free up memory while returning + an error, there will be memory that isn't freed (this will be + detected when the tests are run under a checking memory allocator + such as Purify).} +test subst-4.4 {variable substitutions} { + list [catch {subst {$long $a}} msg] $msg +} {1 {can't read "a": no such variable}} + +test subst-5.1 {command substitutions} { + subst {[concat {}]} +} {} +test subst-5.2 {command substitutions} { + subst {[concat A test string]} +} {A test string} +test subst-5.3 {command substitutions} { + subst {x.[concat foo].y.[concat bar].z} +} {x.foo.y.bar.z} +test subst-5.4 {command substitutions} { + list [catch {subst {$long [set long] [bogus_command]}} msg] $msg +} {1 {invalid command name "bogus_command"}} + +test subst-6.1 {clear the result after command substitution} { + catch {unset a} + list [catch {subst {[concat foo] $a}} msg] $msg +} {1 {can't read "a": no such variable}} + +test subst-7.1 {switches} { + list [catch {subst foo bar} msg] +} {1} +test subst-7.2 {switches} { + list [catch {subst -no bar} msg] +} {1} +test subst-7.3 {switches} { + list [catch {subst -bogus bar} msg] +} {1} +test subst-7.4 {switches} { + set x 123 + subst -nobackslashes {abc $x [expr 1+2] \\\x41} +} {abc 123 3 \\\x41} +test subst-7.5 {switches} { + set x 123 + subst -nocommands {abc $x [expr 1+2] \\\x41} +} {abc 123 [expr 1+2] \A} +test subst-7.6 {switches} { + set x 123 + subst -novariables {abc $x [expr 1+2] \\\x41} +} {abc $x 3 \A} +test subst-7.7 {switches} { + set x 123 + subst -nov -nob -noc {abc $x [expr 1+2] \\\x41} +} {abc $x [expr 1+2] \\\x41} + +test subst-8.1 {return in a subst} { + subst {foo [return {x}; bogus code] bar} +} {foo x bar} +test subst-8.2 {return in a subst} { + subst {foo [return x ; bogus code] bar} +} {foo x bar} +test subst-8.3 {return in a subst} { + subst {foo [if 1 { return {x}; bogus code }] bar} +} {foo x bar} +test subst-8.4 {return in a subst} { + subst {[eval {return hi}] there} +} {hi there} +test subst-8.5 {return in a subst} { + subst {foo [return {]}; bogus code] bar} +} {foo ] bar} + +test subst-9.1 {error in a subst} { + list [catch {subst {[error foo; bogus code]bar}} msg] $msg +} {1 foo} +test subst-9.2 {error in a subst} { + list [catch {subst {[if 1 { error foo; bogus code}]bar}} msg] $msg +} {1 foo} + +test subst-10.1 {break in a subst} { + subst {foo [break; bogus code] bar} +} {foo } +test subst-10.2 {break in a subst} { + subst {foo [break; return x; bogus code] bar} +} {foo } +test subst-10.3 {break in a subst} { + subst {foo [if 1 { break; bogus code}] bar} +} {foo } +test subst-10.4 {break in a subst, parse error} { + subst {foo [break ; set a {}{} ; stuff] bar} +} {foo } +test subst-10.5 {break in a subst, parse error} { + subst {foo [break ;set bar baz ;set a {}{} ; stuff] bar} +} {foo } + +test subst-11.1 {continue in a subst} { + subst {foo [continue; bogus code] bar} +} {foo bar} +test subst-11.2 {continue in a subst} { + subst {foo [continue; return x; bogus code] bar} +} {foo bar} +test subst-11.3 {continue in a subst} { + subst {foo [if 1 { continue; bogus code}] bar} +} {foo bar} + +# cleanup +testreport diff --git a/tests/tree.test b/tests/tree.test index 1b91559..e5b539a 100644 --- a/tests/tree.test +++ b/tests/tree.test @@ -76,15 +76,15 @@ test tree-2.0 "Add more nodes" { test tree-2.1 "walk dfs" { set result {} - puts "" + #puts "" pt walk root dfs {action n} { set indent [string repeat " " [pt depth $n]] if {$action == "enter"} { lappend result [pt get $n name] - puts "$indent[pt get $n name]" + #puts "$indent[pt get $n name]" } } - puts "" + #puts "" set result } {rootnode childnode1 childnode2 n.c4 n.c5 n.c5.c6 root.c2 root.c3} diff --git a/tests/uplevel.test b/tests/uplevel.test new file mode 100644 index 0000000..b3a7714 --- /dev/null +++ b/tests/uplevel.test @@ -0,0 +1,112 @@ +# Commands covered: uplevel +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 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: uplevel.test,v 1.6 2000/04/10 17:19:05 ericm Exp $ + +source testing.tcl + +proc a {x y} { + newset z [expr $x+$y] + return $z +} +proc newset {name value} { + uplevel set $name $value + uplevel 1 {uplevel 1 {set xyz 22}} +} + +test uplevel-1.1 {simple operation} { + set xyz 0 + a 22 33 +} 55 +test uplevel-1.2 {command is another uplevel command} { + set xyz 0 + a 22 33 + set xyz +} 22 + +proc a1 {} { + b1 + global a a1 + set a $x + set a1 $y +} +proc b1 {} { + c1 + global b b1 + set b $x + set b1 $y +} +proc c1 {} { + uplevel 1 set x 111 + uplevel #2 set y 222 + uplevel 2 set x 333 + uplevel #1 set y 444 + uplevel 3 set x 555 + uplevel #0 set y 666 +} +a1 +test uplevel-2.1 {relative and absolute uplevel} {set a} 333 +test uplevel-2.2 {relative and absolute uplevel} {set a1} 444 +test uplevel-2.3 {relative and absolute uplevel} {set b} 111 +test uplevel-2.4 {relative and absolute uplevel} {set b1} 222 +test uplevel-2.5 {relative and absolute uplevel} {set x} 555 +test uplevel-2.6 {relative and absolute uplevel} {set y} 666 + +test uplevel-3.1 {uplevel to same level} { + set x 33 + uplevel #0 set x 44 + set x +} 44 +test uplevel-3.2 {uplevel to same level} { + set x 33 + uplevel 0 set x +} 33 +test uplevel-3.3 {uplevel to same level} { + set y xxx + proc a1 {} {set y 55; uplevel 0 set y 66; return $y} + a1 +} 66 +test uplevel-3.4 {uplevel to same level} { + set y zzz + proc a1 {} {set y 55; uplevel #1 set y} + a1 +} 55 + +test uplevel-4.1 {error: non-existent level} { + list [catch c1 msg] $msg +} {1 {bad level "#2"}} +test uplevel-4.2 {error: non-existent level} { + proc c2 {} {uplevel 3 {set a b}} + list [catch c2 msg] $msg +} {1 {bad level "3"}} +test uplevel-4.3 {error: not enough args} { + list [catch uplevel msg] $msg +} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}} +test uplevel-4.4 {error: not enough args} { + proc upBug {} {uplevel 1} + list [catch upBug msg] $msg +} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}} + +proc a2 {} { + uplevel a3 +} +proc a3 {} { + global x y + set x [info level] + set y [info level 1] +} +a2 +test uplevel-5.1 {info level} {set x} 1 +test uplevel-5.2 {info level} {set y} a3 + +testreport diff --git a/tests/while.test b/tests/while.test new file mode 100644 index 0000000..5368b3e --- /dev/null +++ b/tests/while.test @@ -0,0 +1,127 @@ +# Commands covered: while +# +# This file contains the original set of tests for Tcl's while command. +# Since the while command is now compiled, a new set of tests covering +# the new implementation is in the file "while.test". Sourcing this file +# into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# 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.6 2000/04/10 17:19:06 ericm Exp $ + +source testing.tcl + +test while-old-1.1 {basic while loops} { + set count 0 + while {$count < 10} {set count [expr $count+1]} + set count +} 10 +test while-old-1.2 {basic while loops} { + set value xxx + while {2 > 3} {set value yyy} + set value +} xxx +test while-old-1.3 {basic while loops} { + set value 1 + while {1} { + incr value; + if {$value > 5} { + break; + } + } + set value +} 6 +test while-old-1.4 {basic while loops, multiline test expr} { + set value 1 + while {($tcl_platform(platform) != "foobar1") && \ + ($tcl_platform(platform) != "foobar2")} { + incr value + break + } + set value +} {2} +test while-old-1.5 {basic while loops, test expr in quotes} { + set value 1 + while "0 < 3" {set value 2; break} + set value +} {2} + +test while-old-2.1 {continue in while loop} { + set list {1 2 3 4 5} + set index 0 + set result {} + while {$index < 5} { + if {$index == 2} {set index [expr $index+1]; continue} + set result [concat $result [lindex $list $index]] + set index [expr $index+1] + } + set result +} {1 2 4 5} + +test while-old-3.1 {break in while loop} { + set list {1 2 3 4 5} + set index 0 + set result {} + while {$index < 5} { + if {$index == 3} break + set result [concat $result [lindex $list $index]] + set index [expr $index+1] + } + set result +} {1 2 3} + +test while-old-4.1 {errors in while loops} { + set err [catch {while} msg] + list $err +} {1} +test while-old-4.2 {errors in while loops} { + set err [catch {while 1} msg] + list $err +} {1} +test while-old-4.3 {errors in while loops} { + set err [catch {while 1 2 3} msg] + list $err +} {1} +test while-old-4.4 {errors in while loops} { + set err [catch {while {"a"+"b"} {error "loop aborted"}} msg] + list $err +} {1} +test while-old-4.5 {errors in while loops} { + catch {unset x} + set x 1 + set err [catch {while {$x} {set x foo}} msg] + list $err +} {1} +test while-old-4.6 {errors in while loops} { + set err [catch {while {1} {error "loop aborted"}} msg] + list $err $msg +} {1 {loop aborted}} + +test while-old-5.1 {while return result} { + while {0} {set a 400} +} {} +test while-old-5.2 {while return result} { + set x 1 + while {$x} {set x 0} +} {} + +# cleanup +testreport + + + + + + + + + + + + |