summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSteve Bennett <steveb@workware.net.au>2010-10-30 15:21:21 +1000
committerSteve Bennett <steveb@workware.net.au>2010-11-22 13:27:14 +1000
commit192056900583884bc1f07f371df6478d856ada3b (patch)
tree540618a3e81d8d9e14261e267edb912f5b73710a
parentd98489727fe31fa217d237b36901211adc35282d (diff)
Overhaul unit test framework
Much closer to tcltest now, including constraints. Try to get all appropriate tests running under both Jim and Tcl. Signed-off-by: Steve Bennett <steveb@workware.net.au>
-rw-r--r--Makefile.in3
-rw-r--r--tests/Makefile3
-rw-r--r--tests/alias.test6
-rw-r--r--tests/array.test2
-rw-r--r--tests/case.test6
-rw-r--r--tests/concat.test4
-rw-r--r--tests/dict.test10
-rw-r--r--tests/error.test6
-rw-r--r--tests/event.test15
-rw-r--r--tests/exec.test11
-rw-r--r--tests/exec2.test7
-rw-r--r--tests/expand.test6
-rw-r--r--tests/expr-new.test6
-rw-r--r--tests/expr-old.test4
-rw-r--r--tests/expr.test12
-rw-r--r--tests/filecopy.test7
-rw-r--r--tests/filedir.test7
-rw-r--r--tests/filejoin.test9
-rw-r--r--tests/for.test2
-rw-r--r--tests/format.test38
-rw-r--r--tests/infoframe.test4
-rw-r--r--tests/jim.test26
-rw-r--r--tests/list.test2
-rw-r--r--tests/lsearch.test22
-rw-r--r--tests/lsort.test16
-rw-r--r--tests/lsortcmd.test4
-rw-r--r--tests/misc.test14
-rw-r--r--tests/perf.test6
-rw-r--r--tests/pid.test6
-rw-r--r--tests/proc-new.test6
-rw-r--r--tests/proc.test4
-rw-r--r--tests/regcount.test6
-rw-r--r--tests/regexp.test29
-rw-r--r--tests/regexp2.test12
-rw-r--r--tests/rename.test2
-rw-r--r--tests/return.test4
-rw-r--r--tests/scan.test60
-rw-r--r--tests/stacktrace.test4
-rw-r--r--tests/string.test50
-rw-r--r--tests/stringmatch.test56
-rw-r--r--tests/subst.test2
-rw-r--r--tests/tailcall.test6
-rw-r--r--tests/testing.tcl182
-rw-r--r--tests/timer.test8
-rw-r--r--tests/tree.test8
-rw-r--r--tests/try.test11
-rw-r--r--tests/uplevel.test2
-rw-r--r--tests/upvar.test8
-rw-r--r--tests/utf8.test7
-rw-r--r--tests/utftcl.test6
-rw-r--r--tests/while.test2
51 files changed, 392 insertions, 347 deletions
diff --git a/Makefile.in b/Makefile.in
index 1b077df..22a03ee 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -75,8 +75,7 @@ install: all docs $(EXTENSION_TCL)
install Tcl.html $(DESTDIR)/doc/jim
test:
- $(MAKE) -C tests
-
+ $(MAKE) jimsh=$(shell pwd)/jimsh -C tests
$(OBJS) $(EXTENSION_OBJS): Makefile
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