diff options
Diffstat (limited to 'tests')
50 files changed, 391 insertions, 345 deletions
diff --git a/tests/Makefile b/tests/Makefile index 02c6c1e..caca931 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -5,8 +5,5 @@ export JIMLIB := ..:. test: @set -e; for i in *.test; do $(jimsh) $$i; done -../jimsh: ../*.c - make -C .. all - clean: rm -f gorp.file2 cat gorp.file sleep exit wc sh echo test1 diff --git a/tests/alias.test b/tests/alias.test index 94aa4f1..e0e2775 100644 --- a/tests/alias.test +++ b/tests/alias.test @@ -1,4 +1,6 @@ -source testing.tcl +source [file dirname [info script]]/testing.tcl + +needs constraint jim test alias-1.1 "One word alias" { set x 2 @@ -121,3 +123,5 @@ test local-1.9 "local on existing proc" { } list [info procs a] $result } {{} {2 1}} + +testreport diff --git a/tests/array.test b/tests/array.test index de9283c..efc875c 100644 --- a/tests/array.test +++ b/tests/array.test @@ -1,4 +1,4 @@ -source testing.tcl +source [file dirname [info script]]/testing.tcl array set a { 1 one diff --git a/tests/case.test b/tests/case.test index 74f7405..ad35756 100644 --- a/tests/case.test +++ b/tests/case.test @@ -1,4 +1,6 @@ -source testing.tcl +source [file dirname [info script]]/testing.tcl + +needs cmd case {tclcompat} catch {unset result} test case-1.1 "Simple case" { @@ -80,3 +82,5 @@ test case-2.6 "break from case" { list [catch {do_case 6} msg] $msg } {1 {invoked "break" outside of a loop}} } + +testreport diff --git a/tests/concat.test b/tests/concat.test index 7f961a8..79aec87 100644 --- a/tests/concat.test +++ b/tests/concat.test @@ -1,4 +1,4 @@ -source testing.tcl +source [file dirname [info script]]/testing.tcl test concat-1.1 {simple concatenation} { concat a b c d e f g @@ -62,3 +62,5 @@ test concat-6.6 {Tcl_ConcatObj - utf-8 sequence with "whitespace" char} { # Check for Bug #227512. If this violates C isspace, then it returns \xc3. concat \xe0 } \xe0 + +testreport diff --git a/tests/dict.test b/tests/dict.test index abccdb3..f68db1e 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1,6 +1,4 @@ -package require testing - -section "basic dict" +source [file dirname [info script]]/testing.tcl test dict-1.1 "Basic dict" { set d [dict create] @@ -13,7 +11,7 @@ test dict-1.1 "Basic dict" { catch {unset d} -test dict-2.1 "Dict via reference" { +test dict-2.1 "Dict via reference" references { set d [dict create] dict set d fruit apple dict set d car holden @@ -23,7 +21,7 @@ test dict-2.1 "Dict via reference" { dict get [getref $dref] car } {holden} -test dict-2.2 "Modify dict via reference" { +test dict-2.2 "Modify dict via reference" references { # Get the value out of the refernence set d [getref $dref] # Modify it @@ -34,7 +32,7 @@ test dict-2.2 "Modify dict via reference" { dict get [getref $dref] car } {toyota} -test dict-2.3 "Modify dict via reference - one line" { +test dict-2.3 "Modify dict via reference - one line" references { # Get the value out of the refernence set d [getref $dref] setref $dref [dict set d car toyota] diff --git a/tests/error.test b/tests/error.test index 3a08a6e..54d1731 100644 --- a/tests/error.test +++ b/tests/error.test @@ -1,5 +1,5 @@ -package require testing - +source [file dirname [info script]]/testing.tcl +needs constraint jim proc a {} { error "error thrown from a" } @@ -51,3 +51,5 @@ test error-1.2 "Modify stacktrace" { test error-2.1 "Exit from package" { list [catch -exit {package require exitpackage} msg] $msg } {6 {Can't load package exitpackage}} + +testreport diff --git a/tests/event.test b/tests/event.test index 725d63b..da4af79 100644 --- a/tests/event.test +++ b/tests/event.test @@ -9,10 +9,12 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -source testing.tcl -package-or-skip eventloop +source [file dirname [info script]]/testing.tcl -test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} { +needs cmd after eventloop +testConstraint socket [expr {[info commands socket] ne ""}] + +test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} jim { catch {rename bgerror {}} proc bgerror msg { lappend ::x $msg @@ -80,7 +82,7 @@ test event-11.1 {Tcl_VwaitCmd procedure} { test event-11.2 {Tcl_VwaitCmd procedure} { list [catch {vwait a b} msg] $msg } {1 {wrong # args: should be "vwait name"}} -test event-11.3 {Tcl_VwaitCmd procedure} { +test event-11.3 {Tcl_VwaitCmd procedure} jim { catch {unset x} set x 1 list [catch {vwait x(1)} msg] $msg @@ -105,8 +107,7 @@ foreach i [after info] { after cancel $i } -if {[info commands socket] ne ""} { -test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} { +test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {jim socket} { set f1 [open test1 w] proc accept {s args} { puts $s foobar @@ -129,7 +130,7 @@ test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} { file delete test1 test2 list $x $y $z } {3 3 done} -} + test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} { file delete test1 test2 set f1 [open test1 w] diff --git a/tests/exec.test b/tests/exec.test index a43f065..8b9a743 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -13,8 +13,9 @@ # # RCS: @(#) $Id: exec.test,v 1.8.2.1 2001/10/17 19:29:25 das Exp $ -source testing.tcl -package-or-skip exec +source [file dirname [info script]]/testing.tcl + +needs cmd exec set f [open echo w] puts $f { @@ -304,16 +305,16 @@ test exec-9.2 {commands returning errors} { test exec-9.3 {commands returning errors} { list [catch {exec sleep 1 | false | sleep 1} msg] } {1} -test exec-9.4 {commands returning errors} { +test exec-9.4 {commands returning errors} jim { list [catch {exec false | echo "foo bar"} msg] $msg } {1 {foo bar}} test exec-9.5 {commands returning errors} { list [catch {exec gorp456 | echo a b c} msg] } {1} -test exec-9.6 {commands returning errors} { +test exec-9.6 {commands returning errors} jim { list [catch {exec sh -c "echo error msg 1>&2"} msg] $msg } {0 {error msg}} -test exec-9.7 {commands returning errors} { +test exec-9.7 {commands returning errors} jim { # Note: Use sleep here to ensure the order list [catch {exec sh -c "echo error msg 1 1>&2" \ | sh -c "sleep 1; echo error msg 2 1>&2"} msg] $msg diff --git a/tests/exec2.test b/tests/exec2.test index fcf572f..a15e409 100644 --- a/tests/exec2.test +++ b/tests/exec2.test @@ -2,8 +2,9 @@ # of exec where sh -c must be used and thus we must take extra care # in quoting arguments to exec. -source testing.tcl -package-or-skip exec +source [file dirname [info script]]/testing.tcl + +needs cmd exec set d \" set s ' @@ -38,3 +39,5 @@ test exec2-2.4 "Remove all env var" { unset -nocomplain env exec printenv | sed -n -e /^testenv2=/p } {} + +testreport diff --git a/tests/expand.test b/tests/expand.test index 1527cd9..2c7023a 100644 --- a/tests/expand.test +++ b/tests/expand.test @@ -1,6 +1,4 @@ -source testing.tcl - -section "Expand Testing" +source [file dirname [info script]]/testing.tcl test expand-1.1 "Basic tests" { set a {1 2 3} @@ -8,7 +6,7 @@ test expand-1.1 "Basic tests" { lappend a {*}$b } {1 2 3 4 5 6} -test expand-1.2 "Basic tests" { +test expand-1.2 "Basic tests" jim { set a {1 2 3} set b {4 5 6} lappend a {expand}$b diff --git a/tests/expr-new.test b/tests/expr-new.test index c6da9fc..1130eb1 100644 --- a/tests/expr-new.test +++ b/tests/expr-new.test @@ -12,7 +12,7 @@ # # RCS: @(#) $Id: expr.test,v 1.9 2000/04/10 17:18:59 ericm Exp $ -source testing.tcl +source [file dirname [info script]]/testing.tcl # procedures used below @@ -271,11 +271,11 @@ test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8 # architectures because LONG_MIN is different if {0x80000000 > 0} { - test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} { + test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN (64bit)} jim { expr {1<<63} } -9223372036854775808 } else { - test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} { + test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN (32bit)} jim { expr {1<<31} } -2147483648 } diff --git a/tests/expr-old.test b/tests/expr-old.test index 87d156b..2aacf77 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -15,7 +15,7 @@ # # RCS: @(#) $Id: expr-old.test,v 1.8.2.1 2002/04/18 13:10:27 msofer Exp $ -source testing.tcl +source [file dirname [info script]]/testing.tcl # First, test all of the integer operators individually. @@ -82,7 +82,7 @@ test expr-old-1.53 {integer operators} { # automatic conversion to integers where needed. test expr-old-2.1 {floating-point operators} {expr -4.2} -4.2 -test expr-old-2.2 {floating-point operators} {expr -(1.1+4.2)} -5.3 +test expr-old-2.2 {floating-point operators} jim {expr -(1.1+4.2)} -5.3 test expr-old-2.3 {floating-point operators} {expr +5.7} 5.7 test expr-old-2.4 {floating-point operators} {expr +--+-62.0} -62.0 test expr-old-2.5 {floating-point operators} {expr !2.1} 0 diff --git a/tests/expr.test b/tests/expr.test index a7ba78c..682af89 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -1,6 +1,4 @@ -source testing.tcl - -section "String comparison" +source [file dirname [info script]]/testing.tcl test expr-1.1 "Compare strings lt" { expr {"V000500" < "V000405"} @@ -68,19 +66,19 @@ test expr-1.13 "Short circuit evaluation" { list $a $c } {100 1} -test expr-1.14 "Rotate left" { +test expr-1.14 "Rotate left" jim { expr {1 <<< 5} } {32} -test expr-1.15 "Rotate left" { +test expr-1.15 "Rotate left" jim { expr {1 <<< 65} } {2} -test expr-1.16 "Rotate right" { +test expr-1.16 "Rotate right" jim { expr {1 >>> 48} } {65536} -test expr-1.17 "Rotate left" { +test expr-1.17 "Rotate left" jim { expr {1 >>> 63} } {2} diff --git a/tests/filecopy.test b/tests/filecopy.test index 7dab00f..dc00041 100644 --- a/tests/filecopy.test +++ b/tests/filecopy.test @@ -1,6 +1,7 @@ -source testing.tcl -package-or-skip file -package-or-skip bio +source [file dirname [info script]]/testing.tcl + +needs cmd file +needs cmd bio file mkdir tempdir diff --git a/tests/filedir.test b/tests/filedir.test index 95dbd0c..4dd78ca 100644 --- a/tests/filedir.test +++ b/tests/filedir.test @@ -1,6 +1,7 @@ -source testing.tcl -package-or-skip file -package-or-skip exec +source [file dirname [info script]]/testing.tcl + +needs cmd file +needs cmd exec catch { exec rm -rf tmp diff --git a/tests/filejoin.test b/tests/filejoin.test index c6d2572..0cf1e03 100644 --- a/tests/filejoin.test +++ b/tests/filejoin.test @@ -1,5 +1,6 @@ -source testing.tcl -package-or-skip file +source [file dirname [info script]]/testing.tcl + +needs cmd file test join-1.1 "One name" { file join abc @@ -57,7 +58,9 @@ test join-2.2 "File is empty string" { file join abc "" } {abc} -test join-2.3 "Path too long" { +test join-2.3 "Path too long" jim { set components [string repeat {abcdefghi } 500] list [catch [concat file join $components] msg] $msg } {1 {Path too long}} + +testreport diff --git a/tests/for.test b/tests/for.test index d3a136e..d12385a 100644 --- a/tests/for.test +++ b/tests/for.test @@ -14,7 +14,7 @@ # # RCS: @(#) $Id: for-old.test,v 1.5 2000/04/10 17:18:59 ericm Exp $ -source testing.tcl +source [file dirname [info script]]/testing.tcl # Check "for" and its use of continue and break. diff --git a/tests/format.test b/tests/format.test index 7926379..475be48 100644 --- a/tests/format.test +++ b/tests/format.test @@ -12,7 +12,9 @@ # # RCS: @(#) $Id: format.test,v 1.8 2000/04/10 17:18:59 ericm Exp $ -source testing.tcl +source [file dirname [info script]]/testing.tcl + +needs cmd format # 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 @@ -81,14 +83,12 @@ test format-2.4 {string formatting} { test format-2.5 {string formatting, embedded nulls} { format "%10s" abc\0def } " abc\0def" -ifutf8 { - test format-2.6 {string formatting, international chars} { - format "%10s" abc\ufeffdef - } " abc\ufeffdef" - test format-2.6 {string formatting, international chars} { - format "%.5s" abc\ufeffdef - } "abc\ufeffd" -} +test format-2.6 {string formatting, international chars} utf8 { + format "%10s" abc\ufeffdef +} " abc\ufeffdef" +test format-2.6 {string formatting, international chars} utf8 { + format "%.5s" abc\ufeffdef +} "abc\ufeffd" test format-2.7 {string formatting, international chars} { format "foo\ufeffbar%s" baz } "foo\ufeffbarbaz" @@ -119,16 +119,12 @@ test format-2.8 {string formatting, width and precision} { test format-2.8 {string formatting, width and precision} { format "a%5.7sa" foobarbaz } "afoobarba" - -ifutf8 { - test format-3.1 {Tcl_FormatObjCmd: character formatting} { - format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 65 65 65 65 65 65 3 65 -4 65 - } "|A|A|A|A|A | A| A|A |" - test format-3.2 {Tcl_FormatObjCmd: international character formatting} { - format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 0xa2 0x4e4e 0x25a 0xc3 0xff08 0 3 0x6575 -4 0x4e4f - } "|\ua2|\u4e4e|\u25a|\uc3|\uff08 | \0| \u6575|\u4e4f |" -} - +test format-3.1 {Tcl_FormatObjCmd: character formatting} utf8 { + format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 65 65 65 65 65 65 3 65 -4 65 +} "|A|A|A|A|A | A| A|A |" +test format-3.2 {Tcl_FormatObjCmd: international character formatting} utf8 { + format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 0xa2 0x4e4e 0x25a 0xc3 0xff08 0 3 0x6575 -4 0x4e4f +} "|\ua2|\u4e4e|\u25a|\uc3|\uff08 | \0| \u6575|\u4e4f |" test format-4.1 {e and f formats} { format "%e %e %e %e" 34.2e12 68.514 -.125 -16000. .000053 } {3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04} @@ -279,7 +275,7 @@ test format-7.3 {various syntax features} { test format-8.1 {error conditions} { catch format } 1 -test format-8.2 {error conditions} { +test format-8.2 {error conditions} jim { catch format msg set msg } {wrong # args: should be "format formatString ?arg arg ...?"} @@ -327,7 +323,7 @@ test format-8.14 {error conditions} { test format-8.15 {error conditions} { catch {format %f 2.1z} } 1 -test format-8.16 {error conditions} { +test format-8.16 {error conditions} jim { catch {format %f 2.1z} msg set msg } {expected number but got "2.1z"} diff --git a/tests/infoframe.test b/tests/infoframe.test index 1a637ea..f1619f5 100644 --- a/tests/infoframe.test +++ b/tests/infoframe.test @@ -1,5 +1,5 @@ -source testing.tcl - +source [file dirname [info script]]/testing.tcl +needs constraint jim proc a {n} { if {$n eq "trace"} { stacktrace diff --git a/tests/jim.test b/tests/jim.test index 1fcead3..1d477e2 100644 --- a/tests/jim.test +++ b/tests/jim.test @@ -7,13 +7,11 @@ # # Sometimes tests are modified to reflect different error messages. -source testing.tcl +source [file dirname [info script]]/testing.tcl +needs constraint jim catch {package require regexp} - -if {[info commands regexp] eq ""} { - proc regexp {pat str} {expr {$pat eq "^a*b$" && $str eq "aaaab"}} -} +testConstraint regexp [expr {[info commands regexp] ne {}}] ################################################################################ # SET @@ -2452,7 +2450,7 @@ test switch-3.1 {-exact vs. -glob vs. -regexp} { default {concat none} } } exact -test switch-3.2 {-exact vs. -glob vs. -regexp (no [regexp] cmd)} { +test switch-3.2 {-exact vs. -glob vs. -regexp (no [regexp] cmd)} regexp { rename regexp regexp.none set rc [catch { switch -regexp aaaab { @@ -2466,7 +2464,7 @@ test switch-3.2 {-exact vs. -glob vs. -regexp (no [regexp] cmd)} { set rc } 1 -test switch-3.3 {-exact vs. -glob vs. -regexp (with [regexp] cmd)} { +test switch-3.3 {-exact vs. -glob vs. -regexp (with [regexp] cmd)} regexp { switch -regexp aaaab { ^a*b$ {concat regexp} *b {concat glob} @@ -2516,13 +2514,13 @@ test switch-4.5 {error in default command} { default {error switch2}} msg] $msg } {1 switch2} -#~ test switch-5.1 {errors in -regexp matching} { - #~ list [catch {switch -regexp aaaab { - #~ *b {concat glob} - #~ aaaab {concat exact} - #~ default {concat none} - #~ }} msg] $msg -#~ } {1 {couldn't compile regular expression pattern: quantifier operand invalid}} +test switch-5.1 {errors in -regexp matching} regexp { + list [catch {switch -regexp aaaab { + *b {concat glob} + aaaab {concat exact} + default {concat none} + }} msg] $msg +} {1 {couldn't compile regular expression pattern: quantifier operand invalid}} test switch-6.1 {backslashes in patterns} { switch -exact {\a\$\.\[} { diff --git a/tests/list.test b/tests/list.test index b82a741..3889018 100644 --- a/tests/list.test +++ b/tests/list.test @@ -13,7 +13,7 @@ # # RCS: @(#) $Id: list.test,v 1.5 2000/04/10 17:19:01 ericm Exp $ -source testing.tcl +source [file dirname [info script]]/testing.tcl # First, a bunch of individual tests diff --git a/tests/lsearch.test b/tests/lsearch.test index d1453b6..53642c9 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -13,7 +13,7 @@ # # RCS: @(#) $Id: lsearch.test,v 1.5 2000/04/10 17:19:01 ericm Exp $ -source testing.tcl +source [file dirname [info script]]/testing.tcl set x {abcd bbcd 123 234 345} test lsearch-1.1 {lsearch command} { @@ -136,43 +136,43 @@ test lsearch-5.11 {lsearch -inline, no match} { lsearch -glob -inline {a1 a2 b1 b2 a3 b3} C* } {} -test lsearch-6.1 {lsearch -bool, found} { +test lsearch-6.1 {lsearch -bool, found} jim { lsearch -bool {a1 a2 b1 b2 a3 b3} b1 } {1} -test lsearch-6.2 {lsearch -bool, not found} { +test lsearch-6.2 {lsearch -bool, not found} jim { lsearch -bool {a1 a2 b1 b2 a3 b3} c1 } {0} -test lsearch-6.3 {lsearch -not -bool, found} { +test lsearch-6.3 {lsearch -not -bool, found} jim { lsearch -not -bool {a1 a2 b1 b2 a3 b3} b1 } {0} -test lsearch-6.4 {lsearch -not -bool, not found} { +test lsearch-6.4 {lsearch -not -bool, not found} jim { lsearch -not -bool {a1 a2 b1 b2 a3 b3} c1 } {1} -test lsearch-6.5 {lsearch -bool -all} { +test lsearch-6.5 {lsearch -bool -all} jim { lsearch -bool -glob -all {a1 a2 b1 b2 a3 b3} a* } {1 1 0 0 1 0} -test lsearch-6.6 {lsearch -bool -all no match} { +test lsearch-6.6 {lsearch -bool -all no match} jim { lsearch -bool -glob -all {a1 a2 b1 b2 a3 b3} B* } {0 0 0 0 0 0} -test lsearch-6.7 {lsearch -bool -all -nocase} { +test lsearch-6.7 {lsearch -bool -all -nocase} jim { lsearch -bool -glob -all -nocase {a1 a2 b1 b2 a3 b3} B* } {0 0 1 1 0 1} -test lsearch-6.8 {lsearch -not -bool -all} { +test lsearch-6.8 {lsearch -not -bool -all} jim { lsearch -not -bool -glob -all {a1 a2 b1 b2 a3 b3} a* } {0 0 1 1 0 1} -test lsearch-6.9 {lsearch -not -bool -all no match} { +test lsearch-6.9 {lsearch -not -bool -all no match} jim { lsearch -not -bool -glob -all {a1 a2 b1 b2 a3 b3} B* } {1 1 1 1 1 1} -test lsearch-6.10 {lsearch -not -bool -all -nocase} { +test lsearch-6.10 {lsearch -not -bool -all -nocase} jim { lsearch -not -bool -glob -all -nocase {a1 a2 b1 b2 a3 b3} B* } {1 1 0 0 1 0} diff --git a/tests/lsort.test b/tests/lsort.test index fb04644..1a61fdb 100644 --- a/tests/lsort.test +++ b/tests/lsort.test @@ -10,12 +10,12 @@ # # RCS: @(#) $Id: lsort.test,v 1.12.2.2 2001/10/08 15:50:24 dkf Exp $ -source testing.tcl +source [file dirname [info script]]/testing.tcl -test lsort-1.1 {Tcl_LsortObjCmd procedure} { +test lsort-1.1 {Tcl_LsortObjCmd procedure} jim { list [catch {lsort} msg] $msg } {1 {wrong # args: should be "lsort ?options? list"}} -test lsort-1.2 {Tcl_LsortObjCmd procedure} { +test lsort-1.2 {Tcl_LsortObjCmd procedure} jim { list [catch {lsort -foo {1 3 2 5}} msg] $msg } {1 {bad option "-foo": must be -ascii, -command, -decreasing, -increasing, -index, -integer, or -nocase}} test lsort-1.3 {Tcl_LsortObjCmd procedure, default options} { @@ -121,10 +121,10 @@ test lsort-3.1 {SortCompare procedure, skip comparisons after error} { list [catch {lsort -integer -command cmp {48 6 28 190 16 2 3 6 1}} msg] \ $msg $x } {1 {error #1} 1} -test lsort-3.3 {SortCompare procedure, -index option} { +test lsort-3.3 {SortCompare procedure, -index option} jim { list [catch {lsort -integer -index 2 {{20 10} {15 30 40}}} msg] $msg } {1 {list index out of range}} -test lsort-3.5 {SortCompare procedure, -index option} { +test lsort-3.5 {SortCompare procedure, -index option} jim { list [catch {lsort -integer -index 2 {{20 10 13} {15}}} msg] $msg } {1 {list index out of range}} test lsort-3.6 {SortCompare procedure, -index option} { @@ -154,7 +154,7 @@ test lsort-3.16 {SortCompare procedure, -command option, long command} { } lsort -command {cmp {this argument is very very long in order to make the dstring overflow its statically allocated space}} {{this first element is also long in order to help expand the dstring} {the second element, last but not least, is quite long also, in order to make absolutely sure that space is allocated dynamically for the dstring}} } {{the second element, last but not least, is quite long also, in order to make absolutely sure that space is allocated dynamically for the dstring} {this first element is also long in order to help expand the dstring}} -test lsort-3.17 {SortCompare procedure, -command option, non-integer result} { +test lsort-3.17 {SortCompare procedure, -command option, non-integer result} jim { proc cmp {a b} { return foow } @@ -170,8 +170,7 @@ test lsort-3.19 {SortCompare procedure, -decreasing option} { lsort -decreasing -integer {35 21 0x20 30 023 100 8} } {100 35 0x20 30 21 023 8} -ifutf8 { -test lsort-4.26 {DefaultCompare procedure, signed characters} { +test lsort-4.26 {DefaultCompare procedure, signed characters} utf8 { set l [lsort [list "abc\u80" "abc"]] set viewlist {} foreach s $l { @@ -190,6 +189,5 @@ test lsort-4.26 {DefaultCompare procedure, signed characters} { } set viewlist } [list "abc" "abc\\200"] -} testreport diff --git a/tests/lsortcmd.test b/tests/lsortcmd.test index fc6726b..ed53fe5 100644 --- a/tests/lsortcmd.test +++ b/tests/lsortcmd.test @@ -1,6 +1,4 @@ -source testing.tcl - -section "lsort -command" +source [file dirname [info script]]/testing.tcl set list {b d a c z} diff --git a/tests/misc.test b/tests/misc.test index 0dc1112..ad9dd35 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -1,6 +1,6 @@ -source testing.tcl +source [file dirname [info script]]/testing.tcl -section "Regression Testing" +needs constraint jim catch {unset a b} test regr-1.1 "Double dereference arrays" { @@ -20,7 +20,7 @@ test regr-1.2 "Reference count shared literals" { return 1 } {1} -test regr-1.3 "Invalid for expression" { +test regr-1.3 "Invalid for expression" jim { # Crashes with invalid expression catch { for {set i 0} {$i < n} {incr i} { @@ -41,11 +41,9 @@ test regr-1.5 "lassign with empty list" { info exists c } {1} -section "I/O Testing" - test io-1.1 "Read last line with no newline" { set lines 0 - set f [open testio.in] + set f [open $testdir/testio.in] while {[gets $f buf] >= 0} { incr lines } @@ -53,8 +51,6 @@ test io-1.1 "Read last line with no newline" { list $lines } {2} -section "unset" - set g1 1 set g2 2 array set g3 {4 5 6 7} @@ -111,8 +107,6 @@ proc test_unset {} { test_unset -section "lrepeat" - test lrepeat-1.1 "Basic tests" { lrepeat 1 a } {a} diff --git a/tests/perf.test b/tests/perf.test index 83b13ae..145f432 100644 --- a/tests/perf.test +++ b/tests/perf.test @@ -1,3 +1,7 @@ +source [file dirname [info script]]/testing.tcl + +needs constraint manual + set iterations 10000 set version [info patchlevel] @@ -129,3 +133,5 @@ bench "foreach: assign to dictsugar" {read_file_split_assign_foreach_dictsugar t bench "foreach: assign to dictsugar via lindex" {read_file_split_assign_lindex test.in} file delete test.in + +# testreport diff --git a/tests/pid.test b/tests/pid.test index c539fc4..4ce4d03 100644 --- a/tests/pid.test +++ b/tests/pid.test @@ -13,7 +13,9 @@ # # RCS: @(#) $Id: pid.test,v 1.6 2000/04/10 17:19:03 ericm Exp $ -source testing.tcl +source [file dirname [info script]]/testing.tcl + +needs cmd pid posix file delete test1 @@ -35,7 +37,7 @@ test pid-1.3 {pid command} { close $f set pids } {} -test pid-1.4 {pid command} { +test pid-1.4 {pid command} jim { list [catch {pid a b} msg] $msg } {1 {wrong # args: should be "pid ?chan?"}} test pid-1.5 {pid command} { diff --git a/tests/proc-new.test b/tests/proc-new.test index 324a976..077b43e 100644 --- a/tests/proc-new.test +++ b/tests/proc-new.test @@ -1,4 +1,6 @@ -source testing.tcl +source [file dirname [info script]]/testing.tcl + +needs constraint jim proc aproc {} { list @@ -25,8 +27,6 @@ proc hproc {{a aa} args} { list a $a args $args } -section "Proc - TIP #288" - set n 1 foreach {proc params result} { aproc {} {} diff --git a/tests/proc.test b/tests/proc.test index 985f68b..916893e 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -16,7 +16,9 @@ # # RCS: @(#) $Id: proc-old.test,v 1.6 2000/04/10 17:19:03 ericm Exp $ -source testing.tcl +source [file dirname [info script]]/testing.tcl + +needs constraint jim catch {rename t1 ""} catch {rename foo ""} diff --git a/tests/regcount.test b/tests/regcount.test index 4b4d106..731bfc7 100644 --- a/tests/regcount.test +++ b/tests/regcount.test @@ -1,4 +1,8 @@ -source testing.tcl +source [file dirname [info script]]/testing.tcl + +needs cmd regexp +testConstraint regexp_are [expr {[regexp {\d} 1]}] +needs constraint regexp_are # Test regexp counted repetitions diff --git a/tests/regexp.test b/tests/regexp.test index c6d9a01..a198fc8 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -13,8 +13,9 @@ # # RCS: @(#) $Id: regexp.test,v 1.30.2.1 2008/08/21 23:19:06 hobbs Exp $ -source testing.tcl -package-or-skip regexp +source [file dirname [info script]]/testing.tcl + +needs cmd regexp catch {unset foo} test regexp-1.1 {basic regexp operation} { @@ -191,13 +192,13 @@ test regexp-5.5 {exercise cache of compiled expressions} { regexp .*e xe } 1 -test regexp-6.1 {regexp errors} { +test regexp-6.1 {regexp errors} jim { list [catch {regexp a} msg] $msg } {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}} -test regexp-6.2 {regexp errors} { +test regexp-6.2 {regexp errors} jim { list [catch {regexp -nocase a} msg] $msg } {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}} -test regexp-6.3 {regexp errors} { +test regexp-6.3 {regexp errors} jim { list [catch {regexp -gorp a} msg] $msg } {1 {bad switch "-gorp": must be --, -all, -indices, -inline, -line, -nocase, or -start}} test regexp-6.4 {regexp errors} { @@ -212,7 +213,7 @@ test regexp-6.6 {regexp errors} { test regexp-6.7 {regexp errors} { list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg } {0 0} -test regexp-6.8 {regexp errors} { +test regexp-6.8 {regexp errors} jim { catch {unset f1} set f1 44 list [catch {regexp abc abc f1(f2)} msg] $msg @@ -347,25 +348,25 @@ test regexp-10.3 {newline sensitivity in regsub} { # list [regsub -linestop {a.*b} "da\nbaxyb\nxb" 123 foo] $foo #} "1 {da\nb123\nxb}" -test regexp-11.1 {regsub errors} { +test regexp-11.1 {regsub errors} jim { list [catch {regsub a b} msg] $msg } {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}} -test regexp-11.2 {regsub errors} { +test regexp-11.2 {regsub errors} jim { list [catch {regsub -nocase a b} msg] $msg } {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}} -test regexp-11.3 {regsub errors} { +test regexp-11.3 {regsub errors} jim { list [catch {regsub -nocase -all a b} msg] $msg } {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}} -test regexp-11.4 {regsub errors} { +test regexp-11.4 {regsub errors} jim { list [catch {regsub a b c d e f} msg] $msg } {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}} -test regexp-11.5 {regsub errors} { +test regexp-11.5 {regsub errors} jim { list [catch {regsub -gorp a b c} msg] $msg } {1 {bad switch "-gorp": must be --, -all, -line, -nocase, or -start}} test regexp-11.6 {regsub errors} { list [catch {regsub -nocase a( b c d} msg] [string match *parentheses* $msg] } {1 1} -test regexp-11.7 {regsub errors} { +test regexp-11.7 {regsub errors} jim { catch {unset f1} set f1 44 list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg @@ -639,8 +640,8 @@ test regexp-21.13 {multiple matches handle newlines} { regexp -all -inline -indices -line -- ^ "a\nb\nc" } {{0 -1} {2 1} {4 3}} -test regexp-22.1 {effect of caching} { - +test regexp-22.1 {effect of caching} jim { + set filedata {BEGIN_TABLE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; END_TABLE} # Note: use 2 REs because often libc will cache a single regcomp() result diff --git a/tests/regexp2.test b/tests/regexp2.test index 2349a96..38fe88b 100644 --- a/tests/regexp2.test +++ b/tests/regexp2.test @@ -13,15 +13,11 @@ # # RCS: @(#) $Id$ -source testing.tcl - -catch {package require regexp} -if {[info commands regexp] eq "" || [regexp {\d} 1] == 0} { - # No regexp, or not using a sufficiently capable regexp implementation - puts " --- skipped" - exit 0 -} +source [file dirname [info script]]/testing.tcl +needs cmd regexp +testConstraint regexp_are [regexp {\d} 1] +needs constraint regexp_are # Procedure to evaluate a script within a proc, to test compilation # functionality diff --git a/tests/rename.test b/tests/rename.test index 670637b..6b4afa5 100644 --- a/tests/rename.test +++ b/tests/rename.test @@ -13,7 +13,7 @@ # # RCS: @(#) $Id: rename.test,v 1.8.2.1 2001/09/12 20:34:59 dgp Exp $ -source testing.tcl +source [file dirname [info script]]/testing.tcl # Must eliminate the "unknown" command while the test is running, # especially if the test is being run in a program with its diff --git a/tests/return.test b/tests/return.test index 6fcef8c..94e38a3 100644 --- a/tests/return.test +++ b/tests/return.test @@ -1,4 +1,4 @@ -source testing.tcl +source [file dirname [info script]]/testing.tcl # return -code @@ -46,3 +46,5 @@ test return-2.5 {return -level 1} { test return-2.6 {return -level 2} { list [catch {b 2 20 text} msg] $msg } {20 text} + +testreport diff --git a/tests/scan.test b/tests/scan.test index 63e9751..0614d56 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -1,5 +1,3 @@ -source testing.tcl - # Commands covered: scan # # This file contains a collection of tests for one or more of the Tcl @@ -15,10 +13,14 @@ source testing.tcl # # RCS: @(#) $Id: scan.test,v 1.10.2.2 2002/02/07 01:54:04 hobbs Exp $ +source [file dirname [info script]]/testing.tcl + +needs cmd scan + test scan-1.1 {BuildCharSet, CharInSet} { list [scan foo {%[^o]} x] $x } {1 f} -test scan-1.2 {BuildCharSet, CharInSet} { +test scan-1.2 {BuildCharSet, CharInSet} jim { list [scan \]foo {%[]f]} x] $x } {1 {]f}} test scan-1.3 {BuildCharSet, CharInSet} { @@ -67,7 +69,7 @@ test scan-3.4 {ValidateFormat} { test scan-3.5 {ValidateFormat} { list [catch {scan {} {%10c} a} msg] $msg } {1 {field width may not be specified in %c conversion}} -test scan-3.6 {ValidateFormat} { +test scan-3.6 {ValidateFormat} jim { list [catch {scan {} {%*1$d} a} msg] $msg } {1 {bad scan conversion character}} test scan-3.7 {ValidateFormat} { @@ -92,10 +94,10 @@ test scan-3.13 {ValidateFormat} { list [catch {scan {} {%[^]a} x} msg] $msg } {1 {unmatched [ in format string}} -test scan-4.1 {Tcl_ScanObjCmd, argument checks} { +test scan-4.1 {Tcl_ScanObjCmd, argument checks} jim { list [catch {scan} msg] $msg } {1 {wrong # args: should be "scan string format ?varName varName ...?"}} -test scan-4.2 {Tcl_ScanObjCmd, argument checks} { +test scan-4.2 {Tcl_ScanObjCmd, argument checks} jim { list [catch {scan string} msg] $msg } {1 {wrong # args: should be "scan string format ?varName varName ...?"}} test scan-4.3 {Tcl_ScanObjCmd, argument checks} { @@ -331,6 +333,7 @@ test scan-4.61 {Tcl_ScanObjCmd, set errors} { # procedure that returns the range of integers +# On Tcl with bignum, these won't produce a result! proc int_range {} { for { set MIN_INT 1 } { $MIN_INT > 0 } {} { set MIN_INT [expr { $MIN_INT << 1 }] @@ -339,13 +342,13 @@ proc int_range {} { return [list $MIN_INT $MAX_INT] } -test scan-4.62 {scanning of large and negative octal integers} { +test scan-4.62 {scanning of large and negative octal integers} jim { foreach { MIN_INT MAX_INT } [int_range] {} set scanstring [format {%o %o %o} -1 $MIN_INT $MAX_INT] list [scan $scanstring {%o %o %o} a b c] \ [expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }] } {3 1 1 1} -test scan-4.63 {scanning of large and negative hex integers} { +test scan-4.63 {scanning of large and negative hex integers} jim { foreach { MIN_INT MAX_INT } [int_range] {} set scanstring [format {%x %x %x} -1 $MIN_INT $MAX_INT] list [scan $scanstring {%x %x %x} a b c] \ @@ -434,7 +437,7 @@ test scan-6.5 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] $a $b $c $d } {4 4.6 99999.7 87.643 118.0} -test scan-6.6 {floating-point scanning} { +test scan-6.6 {floating-point scanning} jim { set a {}; set b {}; set c {}; set d {} list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] $a $b $c $d } {4 1.2345 0.697 124.0 5e-05} @@ -467,41 +470,38 @@ test scan-7.5 {string and character scanning} { set a {}; set b {}; set c {} list [scan "aaaaaabc aaabcdefg + + XYZQR" {%*4[a] %s %*4[a]%s%*4[ +]%c} a b c] $a $b $c } {3 aabc bcdefg 43} -ifutf8 { - test scan-7.6 {string and character scanning, unicode} { - set a {}; set b {}; set c {}; set d {} - list [scan "abc d\u00c7fghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d - } "4 abc d\u00c7f ghijk dum" - test scan-7.7 {string and character scanning, unicode} { - set a {}; set b {} - list [scan "ab\u00c7cdef" "ab%c%c" a b] $a $b - } "2 199 99" - test scan-7.8 {string and character scanning, unicode} { - set a {}; set b {} - list [scan "ab\ufeffdef" "%\[ab\ufeff\]" a] $a - } "1 ab\ufeff" -} - +test scan-7.6 {string and character scanning, unicode} utf8 { + set a {}; set b {}; set c {}; set d {} + list [scan "abc d\u00c7fghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d +} "4 abc d\u00c7f ghijk dum" +test scan-7.7 {string and character scanning, unicode} utf8 { + set a {}; set b {} + list [scan "ab\u00c7cdef" "ab%c%c" a b] $a $b +} "2 199 99" +test scan-7.8 {string and character scanning, unicode} utf8 { + set a {}; set b {} + list [scan "ab\ufeffdef" "%\[ab\ufeff\]" a] $a +} "1 ab\ufeff" test scan-8.1 {error conditions} { catch {scan a} } 1 -test scan-8.2 {error conditions} { +test scan-8.2 {error conditions} jim { catch {scan a} msg set msg } {wrong # args: should be "scan string format ?varName varName ...?"} -test scan-8.3 {error conditions} { +test scan-8.3 {error conditions} jim { list [catch {scan a %D x} msg] $msg } {1 {bad scan conversion character}} -test scan-8.4 {error conditions} { +test scan-8.4 {error conditions} jim { list [catch {scan a %O x} msg] $msg } {1 {bad scan conversion character}} -test scan-8.5 {error conditions} { +test scan-8.5 {error conditions} jim { list [catch {scan a %X x} msg] $msg } {1 {bad scan conversion character}} -test scan-8.6 {error conditions} { +test scan-8.6 {error conditions} jim { list [catch {scan a %F x} msg] $msg } {1 {bad scan conversion character}} -test scan-8.7 {error conditions} { +test scan-8.7 {error conditions} jim { list [catch {scan a %E x} msg] $msg } {1 {bad scan conversion character}} test scan-8.8 {error conditions} { diff --git a/tests/stacktrace.test b/tests/stacktrace.test index 91dccbe..3f1428c 100644 --- a/tests/stacktrace.test +++ b/tests/stacktrace.test @@ -1,6 +1,6 @@ -package require testing +source [file dirname [info script]]/testing.tcl +needs constraint jim package require errors - # Make this a proc so that the line numbers don't have to change proc main {} { set id1 0 diff --git a/tests/string.test b/tests/string.test index 220b70e..eecd18e 100644 --- a/tests/string.test +++ b/tests/string.test @@ -13,7 +13,7 @@ # # RCS: @(#) $Id: string.test,v 1.23.2.1 2001/04/03 22:54:38 hobbs Exp $ -source testing.tcl +source [file dirname [info script]]/testing.tcl # Some tests require the testobj command @@ -207,29 +207,28 @@ test string-5.8 {string index} { test string-5.9 {string index} { string index abc end-1 } b -#test string-5.17 {string index, bad integer} { -# list [catch {string index "abc" 08} msg] -#} {1} -#test string-5.18 {string index, bad integer} { -# list [catch {string index "abc" end-00289} msg] -#} {1} - -test string-6.1 {string is, too few args} { +test string-5.17 {string index, bad integer} tcl { + list [catch {string index "abc" 08} msg] +} {1} +test string-5.18 {string index, bad integer} tcl { + list [catch {string index "abc" end-00289} msg] +} {1} +test string-6.1 {string is, too few args} jim { list [catch {string is} msg] $msg } {1 {wrong # args: should be "string is class ?-strict? str"}} -test string-6.2 {string is, too few args} { +test string-6.2 {string is, too few args} jim { list [catch {string is alpha} msg] $msg } {1 {wrong # args: should be "string is class ?-strict? str"}} -test string-6.3 {string is, bad args} { +test string-6.3 {string is, bad args} jim { list [catch {string is alpha -failin str} msg] $msg } {1 {wrong # args: should be "string is class ?-strict? str"}} -test string-6.4 {string is, too many args} { +test string-6.4 {string is, too many args} jim { list [catch {string is alpha -failin var -strict str more} msg] $msg } {1 {wrong # args: should be "string is class ?-strict? str"}} -test string-6.5 {string is, class check} { +test string-6.5 {string is, class check} jim { list [catch {string is bogus str} msg] $msg } {1 {bad class "bogus": must be alnum, alpha, ascii, control, digit, double, graph, integer, lower, print, punct, space, upper, or xdigit}} -test string-6.6 {string is, ambiguous class} { +test string-6.6 {string is, ambiguous class} jim { list [catch {string is al str} msg] $msg } {1 {ambiguous class "al": must be alnum, alpha, ascii, control, digit, double, graph, integer, lower, print, punct, space, upper, or xdigit}} test string-6.10 {string is, ok on empty} { @@ -283,7 +282,7 @@ test string-6.35 {string is double, false} { test string-6.36 {string is double, false} { list [string is double "\n"] } {0} -test string-6.38 {string is double, false on underflow} { +test string-6.38 {string is double, false on underflow} jim { list [string is double 123e-9999] } {0} test string-6.39 {string is double, false} { @@ -406,12 +405,9 @@ test string-7.14 {string last, start index} { test string-7.15 {string last, start index} { string last \u00dca \u00dcad\u00dcad 0 } -1 -ifutf8 { - test string-7.16 {string last, start index} { - string last \u00dca \u00dcad\u00dcad end-1 - } 3 -} - +test string-7.16 {string last, start index} utf8 { + string last \u00dca \u00dcad\u00dcad end-1 +} 3 test string-9.1 {string length} { list [catch {string length} msg] } {1} @@ -600,10 +596,10 @@ test string-11.40 {string match, *special case} { test string-11.41 {string match, *special case} { string match {*[ab]*} abc } 1 -# XXX: I don't see why this shouldn't match. Changed result -test string-11.42 {string match, *special case} { +# I don't see why this shouldn't match. Ignored for jim +test string-11.42 {string match, *special case} tcl { string match "*\\" "\\" -} 1 +} 0 test string-11.43 {string match, *special case} { string match "*\\\\" "\\" } 1 @@ -625,10 +621,10 @@ test string-11.48 {string match, *special case} { test string-11.49 {string match, *special case} { string match "?\\*" "a*" } 1 -# XXX: I don't see why this shouldn't match. Changed result -test string-11.50 {string match, *special case} { +# I don't see why this shouldn't match. Ignored for jim +test string-11.50 {string match, *special case} jim { string match "\\" "\\" -} 1 +} 0 test string-12.1 {string range} { diff --git a/tests/stringmatch.test b/tests/stringmatch.test index b964ed4..dcb0586 100644 --- a/tests/stringmatch.test +++ b/tests/stringmatch.test @@ -9,7 +9,7 @@ # # RCS: @(#) $Id: util.test,v 1.7.2.1 2001/07/16 23:14:13 hobbs Exp $ -source testing.tcl +source [file dirname [info script]]/testing.tcl test stringmatch-5.1 {Tcl_StringMatch} { string match ab*c abc @@ -35,13 +35,11 @@ test stringmatch-5.7 {Tcl_StringMatch: UTF-8} { test stringmatch-5.8 {Tcl_StringMatch} { string match a?c abc } 1 -ifutf8 { - test stringmatch-5.9 {Tcl_StringMatch: UTF-8} { - # skip one character in string +test stringmatch-5.9 {Tcl_StringMatch: UTF-8} utf8 { + # skip one character in string - string match a?c a\u4e4fc - } 1 -} + string match a?c a\u4e4fc +} 1 test stringmatch-5.10 {Tcl_StringMatch} { string match a??c abc } 0 @@ -51,13 +49,11 @@ test stringmatch-5.11 {Tcl_StringMatch} { test stringmatch-5.12 {Tcl_StringMatch} { string match {[abc]bc} abc } 1 -ifutf8 { - test stringmatch-5.13 {Tcl_StringMatch: UTF-8} { - # string += Tcl_UtfToUniChar(string, &ch); +test stringmatch-5.13 {Tcl_StringMatch: UTF-8} utf8 { + # string += Tcl_UtfToUniChar(string, &ch); - string match "\[\u4e4fxy\]bc" "\u4e4fbc" - } 1 -} + string match "\[\u4e4fxy\]bc" "\u4e4fbc" +} 1 test stringmatch-5.14 {Tcl_StringMatch} { # if ((*pattern == ']') || (*pattern == '\0')) # badly formed pattern @@ -73,14 +69,12 @@ test stringmatch-5.15 {Tcl_StringMatch} { test stringmatch-5.16 {Tcl_StringMatch} { string match {a[abc]c} abc } 1 -ifutf8 { - test stringmatch-5.17 {Tcl_StringMatch: UTF-8} { - # pattern += Tcl_UtfToUniChar(pattern, &endChar); - # get 1 UTF-8 character +test stringmatch-5.17 {Tcl_StringMatch: UTF-8} utf8 { + # pattern += Tcl_UtfToUniChar(pattern, &endChar); + # get 1 UTF-8 character - string match "a\[a\u4e4fc]c" "a\u4e4fc" - } 1 -} + string match "a\[a\u4e4fc]c" "a\u4e4fc" +} 1 test stringmatch-5.18 {Tcl_StringMatch: UTF-8} { # pattern += Tcl_UtfToUniChar(pattern, &endChar); # proper advance: wrong answer would match on UTF trail byte of \u4e4f @@ -102,14 +96,12 @@ test stringmatch-5.21 {Tcl_StringMatch} { test stringmatch-5.22 {Tcl_StringMatch: UTF-8 range} { string match "\[\u4e00-\u4e4f]" "0" } 0 -ifutf8 { - test stringmatch-5.23 {Tcl_StringMatch: UTF-8 range} { - string match "\[\u4e00-\u4e4f]" "\u4e33" - } 1 - test stringmatch-5.24 {Tcl_StringMatch: UTF-8 range} { - string match "\[\u4e00-\u4e4f]" "\uff08" - } 0 -} +test stringmatch-5.23 {Tcl_StringMatch: UTF-8 range} utf8 { + string match "\[\u4e00-\u4e4f]" "\u4e33" +} 1 +test stringmatch-5.24 {Tcl_StringMatch: UTF-8 range} utf8 { + string match "\[\u4e00-\u4e4f]" "\uff08" +} 0 test stringmatch-5.25 {Tcl_StringMatch} { string match {12[ab2-4cd]45} 12345 } 1 @@ -164,11 +156,9 @@ test stringmatch-5.41 {Tcl_StringMatch: skip correct number of ']'} { test stringmatch-5.42 {Tcl_StringMatch: skip correct number of ']'} { string match {[A-]]x} \ue1x } 0 -ifutf8 { - test stringmatch-5.43 {Tcl_StringMatch: skip correct number of ']'} { - string match \[A-]\ue1]x \ue1x - } 1 -} +test stringmatch-5.43 {Tcl_StringMatch: skip correct number of ']'} utf8 { + string match \[A-]\ue1]x \ue1x +} 1 test stringmatch-5.44 {Tcl_StringMatch: skip correct number of ']'} { string match {[A-]h]x} hx } 1 diff --git a/tests/subst.test b/tests/subst.test index 4f29c6d..28a2af7 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -13,7 +13,7 @@ # # RCS: @(#) $Id: subst.test,v 1.6.2.1 2001/04/03 22:54:38 hobbs Exp $ -source testing.tcl +source [file dirname [info script]]/testing.tcl test subst-1.0 {basics} { subst {\$x} diff --git a/tests/tailcall.test b/tests/tailcall.test index eb097e5..7ee18c6 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -1,4 +1,6 @@ -source testing.tcl +source [file dirname [info script]]/testing.tcl +needs constraint jim +needs cmd tailcall test tailcall-1.1 {Basic tailcall} { # Demo -- a tail-recursive factorial function @@ -48,3 +50,5 @@ test tailcall-1.5 {interaction of uplevel and tailcall} { } a b } {c c} + +testreport diff --git a/tests/testing.tcl b/tests/testing.tcl index 33e3a7e..4bb19a5 100644 --- a/tests/testing.tcl +++ b/tests/testing.tcl @@ -1,3 +1,65 @@ +# Common code +array set testinfo {verbose 0 numpass 0 numfail 0 numskip 0 numtests 0 failed {}} + +set testdir [file dirname [info script]] + +if {[lsearch $argv "-verbose"] >= 0 || [info exists env(testverbose)]} { + incr testinfo(verbose) +} + +proc needs {type what {packages {}}} { + if {$type eq "constraint"} { + if {![info exists ::tcltest::testConstraints($what)]} { + set ::tcltest::testConstraints($what) 0 + } + if {![set ::tcltest::testConstraints($what)]} { + skiptest " (constraint $what)" + } + return + } + if {$type eq "cmd"} { + # Does it exist already? + if {[info commands $what] ne ""} { + return + } + if {$packages eq ""} { + # e.g. exec command is in exec package + set packages $what + } + foreach p $packages { + catch {package require $p} + } + if {[info commands $what] ne ""} { + return + } + skiptest " (command $what)" + } + error "Unknown needs type: $type" +} + +proc skiptest {{msg {}}} { + puts [format "%16s: --- skipped$msg" $::argv0] + exit 0 +} + +# If tcl, just use tcltest +if {[catch {info version}]} { + package require Tcl 8.5 + package require tcltest 2.1 + namespace import tcltest::* + + if {$testinfo(verbose)} { + configure -verbose bps + } + testConstraint utf8 1 + testConstraint tcl 1 + proc testreport {} { + ::tcltest::cleanupTests + } + return +} + +# For Jim, this is reasonable compatible tcltest proc makeFile {contents name} { set f [open $name w] puts $f $contents @@ -24,93 +86,82 @@ proc package-or-skip {name} { if {[catch { package require $name }]} { - puts " --- skipped" + puts [format "%16s: --- skipped" $::argv0] exit 0 } } -set test(utf8) 0 -if {[string length "\xc2\xb5"] == 1} { - set test(utf8) 1 -} -proc bytestring {x} { - return $x +proc testConstraint {constraint bool} { + set ::tcltest::testConstraints($constraint) $bool } -catch { - # Tcl-only things - info tclversion - proc errorInfo {msg} { - return $::errorInfo - } - proc error_source {} { - } - proc script_source {script} { - } - set test(utf8) 1 - rename bytestring "" - package require tcltest - interp alias {} bytestring {} ::tcltest::bytestring -} - -proc ifutf8 {code} { - if {$::test(utf8)} { - uplevel 1 $code - } -} +testConstraint {utf8} [expr {[string length "\xc2\xb5"] == 1}] +testConstraint {references} [expr {[info commands ref] ne ""}] +testConstraint {jim} 1 -proc section {name} { - if {!$::test(quiet)} { - puts "-- $name ----------------" - } +proc bytestring {x} { + return $x } -set test(numfail) 0 -set test(numpass) 0 -set test(failed) {} - -proc test {id descr script expected} { - if {!$::test(quiet)} { +proc test {id descr script {constraints {}} expected} { + incr ::testinfo(numtests) + if {$::testinfo(verbose)} { puts -nonewline "$id " } + foreach c $constraints { + if {![info exists ::tcltest::testConstraints($c)]} { + incr ::testinfo(numskip) + if {$::testinfo(verbose)} { + puts "SKIP" + } + return + } + } set rc [catch {uplevel 1 $script} result] # Note that rc=2 is return if {($rc == 0 || $rc == 2) && $result eq $expected} { - if {!$::test(quiet)} { + if {$::testinfo(verbose)} { puts "OK $descr" } - incr ::test(numpass) + incr ::testinfo(numpass) + return + } + + if {!$::testinfo(verbose)} { + puts -nonewline "$id " + } + puts "ERR $descr" + if {$rc == 0} { + set source [script_source $script] } else { - if {$::test(quiet)} { - puts -nonewline "$id " - } - puts "ERR $descr" - if {$rc == 0} { - set source [script_source $script] - } else { - set source [error_source] - } - puts "Expected: '$expected'" - puts "Got : '$result'" - incr ::test(numfail) - lappend ::test(failed) [list $id $descr $source $expected $result] + set source [error_source] } + puts "Expected: '$expected'" + puts "Got : '$result'" + incr ::testinfo(numfail) + lappend ::testinfo(failed) [list $id $descr $source $expected $result] } proc testreport {} { - if {!$::test(quiet) || $::test(numfail)} { - puts "----------------------------------------------------------------------" - puts "FAILED: $::test(numfail)" - foreach failed $::test(failed) { + if {$::testinfo(verbose)} { + puts -nonewline "\n$::argv0" + } else { + puts -nonewline [format "%16s" $::argv0] + } + puts [format ": Total %5d Passed %5d Skipped %5d Failed %5d" \ + $::testinfo(numtests) $::testinfo(numpass) $::testinfo(numskip) $::testinfo(numfail)] + if {$::testinfo(numfail)} { + puts [string repeat - 60] + puts "FAILED: $::testinfo(numfail)" + foreach failed $::testinfo(failed) { foreach {id descr source expected result} $failed {} puts "$source\t$id" } - puts "PASSED: $::test(numpass)" - puts "----------------------------------------------------------------------\n" + puts [string repeat - 60] } - if {$::test(numfail)} { + if {$::testinfo(numfail)} { exit 1 } } @@ -119,13 +170,6 @@ proc testerror {} { error "deliberate error" } -set test(quiet) [info exists ::env(testquiet)] -if {[lindex $argv 0] eq "-quiet"} { - incr test(quiet) -} - -if {!$test(quiet)} { - puts [string repeat = 40] - puts $argv0 - puts [string repeat = 40] +if {$testinfo(verbose)} { + puts "==== $argv0 ====" } diff --git a/tests/timer.test b/tests/timer.test index 1cbfc35..ffa55cc 100644 --- a/tests/timer.test +++ b/tests/timer.test @@ -15,8 +15,8 @@ # # RCS: @(#) $Id: timer.test,v 1.7.2.1 2001/10/13 01:14:19 hobbs Exp $ -source testing.tcl -package-or-skip eventloop +source [file dirname [info script]]/testing.tcl +needs cmd after eventloop test timer-1.1 {Tcl_CreateTimerHandler procedure} { foreach i [after info] { @@ -173,10 +173,10 @@ test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} { test timer-6.1 {Tcl_AfterCmd procedure, basics} { list [catch {after} msg] $msg } {1 {wrong # args: should be "after option ?arg ...?"}} -test timer-6.2 {Tcl_AfterCmd procedure, basics} { +test timer-6.2 {Tcl_AfterCmd procedure, basics} jim { list [catch {after 2x} msg] $msg } {1 {bad argument "2x": must be cancel, idle, or info}} -test timer-6.3 {Tcl_AfterCmd procedure, basics} { +test timer-6.3 {Tcl_AfterCmd procedure, basics} jim { list [catch {after gorp} msg] $msg } {1 {bad argument "gorp": must be cancel, idle, or info}} test timer-6.4 {Tcl_AfterCmd procedure, ms argument} { diff --git a/tests/tree.test b/tests/tree.test index cd22916..90f7761 100644 --- a/tests/tree.test +++ b/tests/tree.test @@ -1,7 +1,5 @@ -package require testing -package-or-skip tree - -section "tree" +source [file dirname [info script]]/testing.tcl +needs cmd tree proc dputs {msg} { #puts $msg @@ -113,3 +111,5 @@ test tree-2.3 "walk bfs" { } {rootnode childnode1 root.c2 root.c3 childnode2 n.c4 n.c5 n.c5.c6} $pt destroy + +testreport diff --git a/tests/try.test b/tests/try.test index 7435763..a2bb38a 100644 --- a/tests/try.test +++ b/tests/try.test @@ -1,4 +1,5 @@ -source testing.tcl +source [file dirname [info script]]/testing.tcl +needs cmd try tclcompat test try-1.1 "Simple case" { try { @@ -100,7 +101,11 @@ proc c {} { try { error here } on error {msg opts} { - incr opts(-level) + # jim can do simply: + if {[catch {incr opts(-level)}]} { + # Must be Tcl + dict incr opts -level + } return {*}$opts $msg } } @@ -108,3 +113,5 @@ proc c {} { test try-3.1 "rethrow error in try/on handler" { list [catch c msg] $msg } {1 here} + +testreport diff --git a/tests/uplevel.test b/tests/uplevel.test index 0d38c13..e91a5ea 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -13,7 +13,7 @@ # # RCS: @(#) $Id: uplevel.test,v 1.6 2000/04/10 17:19:05 ericm Exp $ -source testing.tcl +source [file dirname [info script]]/testing.tcl proc a {x y} { newset z [expr $x+$y] diff --git a/tests/upvar.test b/tests/upvar.test index cca8360..12318e3 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -13,7 +13,7 @@ # # RCS: @(#) $Id: upvar.test,v 1.7 2000/04/10 17:19:05 ericm Exp $ -source testing.tcl +source [file dirname [info script]]/testing.tcl test upvar-1.1 {reading variables with upvar} { proc p1 {a b} {set c 22; set d 33; p2} @@ -287,7 +287,7 @@ test upvar-8.6 {errors in upvar command} { list [catch p1 msg] $msg } {1 {variable "a" already exists}} # Jim allows dicts within dicts. Tcl can't do this. -test upvar-8.8 {create nested array with upvar} { +test upvar-8.8 {create nested array with upvar} jim { proc p1 {} {upvar x(a) b; set b(2) 44} catch {unset x} p1 @@ -308,11 +308,11 @@ test upvar-9.2 {upvar redefine} { proc p1 {} { upvar a x; upvar b x; return $x } p1 } 2 -test upvar-9.3 {upvar redefine static} { +test upvar-9.3 {upvar redefine static} jim { proc p1 {} {{a 3}} { upvar b a; return $b } list [catch p1 msg] $msg } {1 {variable "a" already exists}} -test upvar-9.4 {upvar links to static} { +test upvar-9.4 {upvar links to static} jim { proc p1 {} {} { upvar a x; incr x; return $x } proc p2 {} {{a 3}} { list [p1] $a } p2 diff --git a/tests/utf8.test b/tests/utf8.test index ecb5111..04c5b57 100644 --- a/tests/utf8.test +++ b/tests/utf8.test @@ -1,8 +1,6 @@ -source testing.tcl +source [file dirname [info script]]/testing.tcl -ifutf8 { - -section "string tests" +needs constraint utf8 test utf8-1.1 "Pattern matching - ?" { string match "abc?def" "abc\u00b5def" @@ -128,4 +126,3 @@ test utf8-7.2 {append counts correctly} { } {8 12} testreport -} diff --git a/tests/utftcl.test b/tests/utftcl.test index 468cff1..db058c2 100644 --- a/tests/utftcl.test +++ b/tests/utftcl.test @@ -10,9 +10,9 @@ # # RCS: @(#) $Id: utf.test,v 1.14 2007/05/02 01:37:28 kennykb Exp $ -source testing.tcl +source [file dirname [info script]]/testing.tcl -ifutf8 { +needs constraint utf8 catch {unset x} @@ -286,5 +286,3 @@ test utf-17.1 {Tcl_UniCharToLower, no delta} { #} {1 1} testreport - -} diff --git a/tests/while.test b/tests/while.test index 5368b3e..de6d9b5 100644 --- a/tests/while.test +++ b/tests/while.test @@ -15,7 +15,7 @@ # # RCS: @(#) $Id: while-old.test,v 1.6 2000/04/10 17:19:06 ericm Exp $ -source testing.tcl +source [file dirname [info script]]/testing.tcl test while-old-1.1 {basic while loops} { set count 0 |