summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2012-08-11 21:24:22 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2012-08-11 21:24:22 (GMT)
commit944fd5bdcf2e247575a9dd55704b37fbc2a1e9ac (patch)
tree27fde8f62082347078d925d76441498acc190a4a /tests
parent9dee089fa2567d307056363c20eb69c53b4e1655 (diff)
parent88b202715dfbdfc05b7ce33d7f176595620496be (diff)
downloadtcl-944fd5bdcf2e247575a9dd55704b37fbc2a1e9ac.zip
tcl-944fd5bdcf2e247575a9dd55704b37fbc2a1e9ac.tar.gz
tcl-944fd5bdcf2e247575a9dd55704b37fbc2a1e9ac.tar.bz2
merge trunk
Diffstat (limited to 'tests')
-rw-r--r--tests/assocd.test3
-rw-r--r--tests/async.test3
-rw-r--r--tests/basic.test3
-rw-r--r--tests/chanio.test3
-rw-r--r--tests/clock.test6
-rw-r--r--tests/cmdAH.test3
-rw-r--r--tests/cmdIL.test3
-rw-r--r--tests/cmdInfo.test3
-rw-r--r--tests/compExpr-old.test3
-rw-r--r--tests/compExpr.test3
-rw-r--r--tests/compile.test3
-rw-r--r--tests/coroutine.test3
-rw-r--r--tests/dcall.test3
-rw-r--r--tests/dstring.test3
-rw-r--r--tests/encoding.test11
-rw-r--r--tests/event.test12
-rw-r--r--tests/execute.test3
-rw-r--r--tests/expr-old.test3
-rw-r--r--tests/expr.test3
-rw-r--r--tests/fCmd.test3
-rw-r--r--tests/fileName.test9
-rw-r--r--tests/fileSystem.test31
-rw-r--r--tests/format.test7
-rw-r--r--tests/get.test3
-rw-r--r--tests/http.test15
-rw-r--r--tests/indexObj.test3
-rw-r--r--tests/info.test20
-rw-r--r--tests/interp.test3
-rw-r--r--tests/io.test4
-rw-r--r--tests/ioCmd.test3
-rw-r--r--tests/ioTrans.test3
-rw-r--r--tests/iogt.test4
-rw-r--r--tests/lindex.test3
-rw-r--r--tests/link.test3
-rw-r--r--tests/listObj.test3
-rw-r--r--tests/load.test5
-rw-r--r--tests/lset.test3
-rw-r--r--tests/misc.test3
-rw-r--r--tests/namespace.test3
-rwxr-xr-xtests/notify.test3
-rw-r--r--tests/nre.test3
-rw-r--r--tests/obj.test3
-rw-r--r--tests/parse.test3
-rw-r--r--tests/parseExpr.test3
-rw-r--r--tests/parseOld.test3
-rw-r--r--tests/platform.test3
-rw-r--r--tests/reg.test3
-rw-r--r--tests/registry.test14
-rw-r--r--tests/rename.test3
-rw-r--r--tests/resolver.test3
-rw-r--r--tests/result.test3
-rw-r--r--tests/set.test3
-rw-r--r--tests/string.test7
-rw-r--r--tests/stringComp.test3
-rw-r--r--tests/stringObj.test3
-rw-r--r--tests/tailcall.test3
-rw-r--r--tests/thread.test3
-rw-r--r--tests/trace.test3
-rw-r--r--tests/unixFCmd.test3
-rw-r--r--tests/unixFile.test3
-rw-r--r--tests/unload.test3
-rw-r--r--tests/upvar.test3
-rw-r--r--tests/utf.test3
-rw-r--r--tests/util.test3
-rw-r--r--tests/var.test3
-rw-r--r--tests/winDde.test80
-rw-r--r--tests/winFCmd.test3
-rw-r--r--tests/winFile.test3
-rw-r--r--tests/winNotify.test3
-rw-r--r--tests/winPipe.test20
-rw-r--r--tests/winTime.test3
71 files changed, 333 insertions, 80 deletions
diff --git a/tests/assocd.test b/tests/assocd.test
index 1ca1c9b..d1489b3 100644
--- a/tests/assocd.test
+++ b/tests/assocd.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testgetassocdata [llength [info commands testgetassocdata]]
testConstraint testsetassocdata [llength [info commands testsetassocdata]]
testConstraint testdelassocdata [llength [info commands testdelassocdata]]
diff --git a/tests/async.test b/tests/async.test
index 35dda88..cb67cc2 100644
--- a/tests/async.test
+++ b/tests/async.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testasync [llength [info commands testasync]]
testConstraint threaded [::tcl::pkgconfig get threaded]
diff --git a/tests/basic.test b/tests/basic.test
index e072bea..7435571 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -18,6 +18,9 @@
package require tcltest 2
namespace import -force ::tcltest::*
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
testConstraint testcreatecommand [llength [info commands testcreatecommand]]
diff --git a/tests/chanio.test b/tests/chanio.test
index fbc9854..9bb11f7 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -29,6 +29,9 @@ namespace eval ::tcl::test::io {
variable msg
variable expected
+ ::tcltest::loadTestedCommands
+ catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]
testConstraint openpipe 1
diff --git a/tests/clock.test b/tests/clock.test
index fd74512..0202fc7 100644
--- a/tests/clock.test
+++ b/tests/clock.test
@@ -17,11 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
}
if {[testConstraint win]} {
- if {[catch {package require registry 1.1}]
- && [catch {load {} Registry}]
- && [catch {
+ if {[catch {
::tcltest::loadTestedCommands
- load $::reglib Registry
+ package require registry
}]} {
namespace eval ::tcl::clock {variable NoRegistry {}}
}
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index 291df8d..2ecf626 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -15,6 +15,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testchmod [llength [info commands testchmod]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
diff --git a/tests/cmdIL.test b/tests/cmdIL.test
index 4b1002a..efb0bce 100644
--- a/tests/cmdIL.test
+++ b/tests/cmdIL.test
@@ -13,6 +13,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
testConstraint testobj [llength [info commands testobj]]
diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test
index 86aa6e1..69d7171 100644
--- a/tests/cmdInfo.test
+++ b/tests/cmdInfo.test
@@ -18,6 +18,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testcmdinfo [llength [info commands testcmdinfo]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test
index bb19151..bae26a0 100644
--- a/tests/compExpr-old.test
+++ b/tests/compExpr-old.test
@@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
testConstraint testmathfunctions 0
} else {
diff --git a/tests/compExpr.test b/tests/compExpr.test
index 8e27f1f..14c875d 100644
--- a/tests/compExpr.test
+++ b/tests/compExpr.test
@@ -13,6 +13,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
testConstraint testmathfunctions 0
} else {
diff --git a/tests/compile.test b/tests/compile.test
index d6048be..4d91940 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -14,6 +14,9 @@
package require tcltest 2
namespace import -force ::tcltest::*
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint exec [llength [info commands exec]]
testConstraint memory [llength [info commands memory]]
testConstraint testevalex [llength [info commands testevalex]]
diff --git a/tests/coroutine.test b/tests/coroutine.test
index 7f40a7b..8272717 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -14,6 +14,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testnrelevels [llength [info commands testnrelevels]]
testConstraint memory [llength [info commands memory]]
diff --git a/tests/dcall.test b/tests/dcall.test
index 8977c31..3df0ac8 100644
--- a/tests/dcall.test
+++ b/tests/dcall.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testdcall [llength [info commands testdcall]]
test dcall-1.1 {deletion callbacks} testdcall {
diff --git a/tests/dstring.test b/tests/dstring.test
index bcc304d..06121a3 100644
--- a/tests/dstring.test
+++ b/tests/dstring.test
@@ -16,6 +16,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testdstring [llength [info commands testdstring]]
if {[testConstraint testdstring]} {
testdstring free
diff --git a/tests/encoding.test b/tests/encoding.test
index b4ee7c3..0374e2d 100644
--- a/tests/encoding.test
+++ b/tests/encoding.test
@@ -15,6 +15,11 @@ namespace eval ::tcl::test::encoding {
namespace import -force ::tcltest::*
+catch {
+ ::tcltest::loadTestedCommands
+ package require -exact Tcltest [info patchlevel]
+}
+
proc toutf {args} {
variable x
lappend x "toutf $args"
@@ -31,7 +36,6 @@ proc runtests {} {
testConstraint testencoding [llength [info commands testencoding]]
testConstraint exec [llength [info commands exec]]
testConstraint testgetdefenc [llength [info commands testgetdefenc]]
-testConstraint testfinexit [llength [info commands testfinexit]]
# TclInitEncodingSubsystem is tested by the rest of this file
# TclFinalizeEncodingSubsystem is not currently tested
@@ -418,13 +422,14 @@ test encoding-24.1 {EscapeFreeProc on open channels} exec {
gets $f
}
} {}
-test encoding-24.2 {EscapeFreeProc on open channels} {exec testfinexit} {
+test encoding-24.2 {EscapeFreeProc on open channels} {exec} {
# Bug #524674 output
viewable [runInSubprocess {
encoding system cp1252; # Bug #2891556 crash revelator
fconfigure stdout -encoding iso2022-jp
puts ab\u4e4e\u68d9g
- testfinexit
+ set env(TCL_FINALIZE_ON_EXIT) 1
+ exit
}]
} "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)"
test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
diff --git a/tests/event.test b/tests/event.test
index 0ee7558..0d1b06c 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -12,6 +12,13 @@
package require tcltest 2
namespace import -force ::tcltest::*
+catch {
+ ::tcltest::loadTestedCommands
+ package require -exact Tcltest [info patchlevel]
+ set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
+}
+
+
testConstraint testfilehandler [llength [info commands testfilehandler]]
testConstraint testexithandler [llength [info commands testexithandler]]
testConstraint testfilewait [llength [info commands testfilewait]]
@@ -427,6 +434,7 @@ catch {rename bgerror {}}
test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
+ puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; exit"
flush $child
@@ -440,6 +448,7 @@ odd 41
test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
+ puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
@@ -453,6 +462,7 @@ even 4
}
test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
+ puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 4"
puts $child "testexithandler create 16; exit"
@@ -466,6 +476,7 @@ odd 41
}
test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
+ puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 6"
puts $child "testexithandler create 16; exit"
@@ -479,6 +490,7 @@ odd 41
}
test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
+ puts $child "catch {load $::tcltestlib Tcltest}"
puts $child "testexithandler create 41; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
flush $child
diff --git a/tests/execute.test b/tests/execute.test
index 012b3a7..94af158 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -19,6 +19,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
diff --git a/tests/expr-old.test b/tests/expr-old.test
index c05a925..4f3cb2e 100644
--- a/tests/expr-old.test
+++ b/tests/expr-old.test
@@ -18,6 +18,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testexprlong [llength [info commands testexprlong]]
testConstraint testexprdouble [llength [info commands testexprdouble]]
testConstraint testexprstring [llength [info commands testexprstring]]
diff --git a/tests/expr.test b/tests/expr.test
index 6679569..6ad7208 100644
--- a/tests/expr.test
+++ b/tests/expr.test
@@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testmathfunctions [expr {
([catch {expr T1()} msg] != 1) || ($msg ne {invalid command name "tcl::mathfunc::T1"})
}]
diff --git a/tests/fCmd.test b/tests/fCmd.test
index 72b7da9..325b374 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -15,6 +15,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
cd [temporaryDirectory]
testConstraint testsetplatform [llength [info commands testsetplatform]]
diff --git a/tests/fileName.test b/tests/fileName.test
index 251f12c..6dd1cb4 100644
--- a/tests/fileName.test
+++ b/tests/fileName.test
@@ -15,6 +15,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testtranslatefilename [llength [info commands testtranslatefilename]]
testConstraint linkDirectory 1
@@ -196,7 +199,7 @@ test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} {
test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split //foo
-} "[file split //] foo"
+} "/ foo"
test filename-4.14 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split foo//bar
@@ -433,11 +436,11 @@ test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} {
test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join //a b
-} "[file split //]a/b"
+} "/a/b"
test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /// a b
-} "[file split //]a/b"
+} "/a/b"
test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
diff --git a/tests/fileSystem.test b/tests/fileSystem.test
index 9950dde..38ecbee 100644
--- a/tests/fileSystem.test
+++ b/tests/fileSystem.test
@@ -19,6 +19,17 @@ namespace eval ::tcl::test::fileSystem {
file delete -force [file join dir.dir linkinside.file]
}
+testConstraint loaddll 0
+catch {
+ ::tcltest::loadTestedCommands
+ package require -exact Tcltest [info patchlevel]
+ set ::ddever [package require dde]
+ set ::ddelib [lindex [package ifneeded dde $::ddever] 1]
+ set ::regver [package require registry]
+ set ::reglib [lindex [package ifneeded registry $::regver] 1]
+ testConstraint loaddll 0
+}
+
# Test for commands defined in Tcltest executable
testConstraint testfilesystem [llength [info commands ::testfilesystem]]
testConstraint testsetplatform [llength [info commands ::testsetplatform]]
@@ -305,7 +316,7 @@ test filesystem-1.39 {file normalisation with volume relative} -setup {
file norm [string range $drv 0 1]
} -cleanup {
cd $old
-} -match glob -result {*[^/]}
+} -match regexp -result {.*[^/]}
test filesystem-1.40 {file normalisation with repeated separators} {
testPathEqual [file norm foo////bar] [file norm foo/bar]
} ok
@@ -473,7 +484,7 @@ test filesystem-6.22 {empty file name} {file pathtype ""} relative
test filesystem-6.23 {empty file name} {file readable ""} 0
test filesystem-6.24 {empty file name} -returnCodes error -body {
file readlink ""
-} -result {could not readlink "": no such file or directory}
+} -result {could not read link "": no such file or directory}
test filesystem-6.25 {empty file name} -returnCodes error -body {
file rename "" ""
} -result {error renaming "": no such file or directory}
@@ -501,13 +512,12 @@ if {[testConstraint testfilesystem]} {
test filesystem-7.1.1 {load from vfs} -setup {
set dir [pwd]
-} -constraints {win testsimplefilesystem} -body {
+} -constraints {win testsimplefilesystem loaddll} -body {
# This may cause a crash on exit
- cd [file dirname [info nameof]]
- set dde [lindex [glob *dde*[info sharedlib]] 0]
+ cd [file dirname $::reglib]
testsimplefilesystem 1
# This loads dde via a complex copy-to-temp operation
- load simplefs:/$dde dde
+ load simplefs:/[file tail $::ddelib] dde
testsimplefilesystem 0
return ok
# The real result of this test is what happens when Tcl exits.
@@ -516,14 +526,13 @@ test filesystem-7.1.1 {load from vfs} -setup {
} -result ok
test filesystem-7.1.2 {load from vfs, and then unload again} -setup {
set dir [pwd]
-} -constraints {win testsimplefilesystem} -body {
+} -constraints {win testsimplefilesystem loaddll} -body {
# This may cause a crash on exit
- cd [file dirname [info nameof]]
- set reg [lindex [glob tclreg*[info sharedlib]] 0]
+ cd [file dirname $::reglib]
testsimplefilesystem 1
# This loads reg via a complex copy-to-temp operation
- load simplefs:/$reg Registry
- unload simplefs:/$reg
+ load simplefs:/[file tail $::reglib] Registry
+ unload simplefs:/[file tail $::reglib]
testsimplefilesystem 0
return ok
# The real result of this test is what happens when Tcl exits.
diff --git a/tests/format.test b/tests/format.test
index 2d53eba..27eac31 100644
--- a/tests/format.test
+++ b/tests/format.test
@@ -549,10 +549,7 @@ test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} {
list [format %08x $a] [expr {$a == $b}]
} {aaaaaaab 1}
-test format-19.1 {
- regression test - tcl-core message by Brian Griffin on
- 26 0ctober 2004
-} -body {
+test format-19.1 {regression test - tcl-core message by Brian Griffin on 26 0ctober 2004} -body {
set x 0x8fedc654
list [expr { ~ $x }] [format %08x [expr { ~$x }]]
} -match regexp -result {-2414724693 f*701239ab}
@@ -569,7 +566,7 @@ test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body {
format %s $x
# After this, obj in $x should be a dict with a non-NULL bytes field
tcl::unsupported::representation $x
-} -match glob -result {value is a dict with *, string representation "*".}
+} -match glob -result {value is a dict with *, string representation "*"}
# cleanup
catch {unset a}
diff --git a/tests/get.test b/tests/get.test
index 40ec98f..d51ec6d 100644
--- a/tests/get.test
+++ b/tests/get.test
@@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testgetint [llength [info commands testgetint]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
diff --git a/tests/http.test b/tests/http.test
index 37d4a05..bde5795 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -135,6 +135,7 @@ set fullurl http://user:pass@[info hostname]:$port/a/b/c
set binurl //[info hostname]:$port/binary
set posturl //[info hostname]:$port/post
set badposturl //[info hostname]:$port/droppost
+set ipv6url http://\[::1\]:$port/
test http-3.4 {http::geturl} -body {
set token [http::geturl $url]
http::data $token
@@ -390,6 +391,20 @@ Connection close
Content-Type {text/plain;charset=utf-8}
Accept-Encoding .*
Content-Length 5}
+test http-3.29 "http::geturl $ipv6url" -body {
+ # We only want to see if the URL gets parsed correctly. This is
+ # the case if http::geturl succeeds or returns a socket related
+ # error. If the parsing is wrong, we'll get a parse error.
+ # It'd be better to separate the URL parser from http::geturl, so
+ # that it can be tested without also trying to make a connection.
+ set error [catch {http::geturl $ipv6url -validate 1} token]
+ if {$error && [string match "couldn't open socket: *" $token]} {
+ set error 0
+ }
+ set error
+} -cleanup {
+ catch { http::cleanup $token }
+} -result 0
test http-4.1 {http::Event} -body {
set token [http::geturl $url -keepalive 0]
diff --git a/tests/indexObj.test b/tests/indexObj.test
index 479cc3b..646cb02 100644
--- a/tests/indexObj.test
+++ b/tests/indexObj.test
@@ -13,6 +13,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testindexobj [llength [info commands testindexobj]]
testConstraint testparseargs [llength [info commands testparseargs]]
diff --git a/tests/info.test b/tests/info.test
index 3323281..7dd63b7 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -20,6 +20,9 @@ if {{::tcltest} ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.
@@ -231,7 +234,6 @@ test info-6.11 {info default option} {
}
} {0 {} 1 27}
-
test info-7.1 {info exists option} -body {
set value foo
info exists value
@@ -731,8 +733,6 @@ proc etrace {} {
return $res
}
-##
-
test info-22.0 {info frame, levels} {!singleTestInterp} {
info frame
} 7
@@ -763,7 +763,7 @@ test info-22.7 {info frame, global, absolute} {!singleTestInterp} {
} {type source line 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0}
test info-22.8 {info frame, basic trace} -match glob -body {
join [lrange [etrace] 0 2] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
+} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest}
* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
unset -nocomplain msg
@@ -803,7 +803,7 @@ test info-23.5 {eval'd info frame, dynamic} -cleanup {unset script} -body {
test info-23.6 {eval'd info frame, trace} -match glob -cleanup {unset script} -body {
set script {etrace}
join [lrange [eval $script] 0 2] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
+} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
* {type source line 805 file info.test cmd {eval $script} proc ::tcltest::RunTest}}
@@ -1318,7 +1318,7 @@ test info-37.0 {eval pure list, single line} -match glob -body {
}]
eval $cmd
return $res
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
+} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 2 cmd etrace proc ::tcltest::RunTest}
* {type eval line 1 cmd foreac proc ::tcltest::RunTest}} -cleanup {unset foo cmd res b c}
@@ -1359,7 +1359,7 @@ test info-38.1 {location information for uplevel, dv, direct-var} -match glob -b
etrace
}
join [lrange [uplevel \#0 $script] 0 2] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
+} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::tcltest::RunTest}
* {type source line 1361 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y}
@@ -1378,7 +1378,7 @@ test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match g
etrace
}
join [lrange [control y $script] 0 3] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
+} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1380 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y}
@@ -1395,7 +1395,7 @@ test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match g
test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body {
join [lrange [datav] 0 4] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
+} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1353 file info.test cmd {control y $script} proc ::datav level 1}
@@ -1412,7 +1412,7 @@ test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glo
testConstraint testevalex [llength [info commands testevalex]]
test info-38.7 {location information for arg substitution} -constraints testevalex -match glob -body {
join [lrange [testevalex {return -level 0 [etrace]}] 0 3] \n
-} -result {* {type source line 728 file info.test cmd {info frame \$level} proc ::etrace level 0}
+} -result {* {type source line 730 file info.test cmd {info frame \$level} proc ::etrace level 0}
* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
* {type source line 1414 file info.test cmd {testevalex {return -level 0 \[etrace]}} proc ::tcltest::RunTest}
* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
diff --git a/tests/interp.test b/tests/interp.test
index ab91f77..0af9887 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -15,6 +15,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testinterpdelete [llength [info commands testinterpdelete]]
set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload}
diff --git a/tests/io.test b/tests/io.test
index f3c39f4..9621138 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -17,6 +17,10 @@ if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
+
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index cf913ff..5eb0206 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -18,6 +18,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Custom constraints used in this file
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testchannel [llength [info commands testchannel]]
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
index 7da4329..db9a2cb 100644
--- a/tests/ioTrans.test
+++ b/tests/ioTrans.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Custom constraints used in this file
testConstraint testchannel [llength [info commands testchannel]]
testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
diff --git a/tests/iogt.test b/tests/iogt.test
index 60d7ab8..d4c31d2 100644
--- a/tests/iogt.test
+++ b/tests/iogt.test
@@ -14,6 +14,10 @@ if {[catch {package require tcltest 2.1}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
return
}
+
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
namespace eval ::tcl::test::iogt {
namespace import ::tcltest::*
diff --git a/tests/lindex.test b/tests/lindex.test
index 07abff8..b86e2e0 100644
--- a/tests/lindex.test
+++ b/tests/lindex.test
@@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
set minus -
testConstraint testevalex [llength [info commands testevalex]]
diff --git a/tests/link.test b/tests/link.test
index 60d0799..00e490c 100644
--- a/tests/link.test
+++ b/tests/link.test
@@ -16,6 +16,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testlink [llength [info commands testlink]]
foreach i {int real bool string} {
diff --git a/tests/listObj.test b/tests/listObj.test
index 53017b1..8b24aa9 100644
--- a/tests/listObj.test
+++ b/tests/listObj.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testobj [llength [info commands testobj]]
catch {unset x}
diff --git a/tests/load.test b/tests/load.test
index b7c1a59..78bf64c 100644
--- a/tests/load.test
+++ b/tests/load.test
@@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Figure out what extension is used for shared libraries on this
# platform.
if {![info exists ext]} {
@@ -197,7 +200,7 @@ test load-9.1 {Tcl_StaticPackage, load already-loaded package into another inter
[child1 eval { info loaded {} }] \
[child2 eval { info loaded {} }]
} \
- -result {{{{} Loadninepointone} {{} Tcltest}} {{{} Loadninepointone} {{} Tcltest}}} \
+ -match glob -result {{{{} Loadninepointone} {* Tcltest}} {{{} Loadninepointone} {* Tcltest}}} \
-cleanup { interp delete child1 ; interp delete child2 }
test load-10.1 {load from vfs} \
diff --git a/tests/lset.test b/tests/lset.test
index 3f4914d..1c1300b 100644
--- a/tests/lset.test
+++ b/tests/lset.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
proc failTrace {name1 name2 op} {
error "trace failed"
}
diff --git a/tests/misc.test b/tests/misc.test
index fe19ebe..6ddc718 100644
--- a/tests/misc.test
+++ b/tests/misc.test
@@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testhashsystemhash [llength [info commands testhashsystemhash]]
test misc-1.1 {error in variable ref. in command in array reference} {
diff --git a/tests/namespace.test b/tests/namespace.test
index f07d8cf..1d46bf0 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -16,6 +16,9 @@ package require tcltest 2
namespace import -force ::tcltest::*
testConstraint memory [llength [info commands memory]]
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
#
# REMARK: the tests for 'namespace upvar' are not done here. They are to be
# found in the file 'upvar.test'.
diff --git a/tests/notify.test b/tests/notify.test
index ba52c50..d2b9123 100755
--- a/tests/notify.test
+++ b/tests/notify.test
@@ -18,6 +18,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testevent [llength [info commands testevent]]
test notify-1.1 {Tcl_QueueEvent and delivery of a single event} \
diff --git a/tests/nre.test b/tests/nre.test
index 295f02e..b8ef2e0 100644
--- a/tests/nre.test
+++ b/tests/nre.test
@@ -14,6 +14,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testnrelevels [llength [info commands testnrelevels]]
#
diff --git a/tests/obj.test b/tests/obj.test
index 126d5ca..71a39b4 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testobj [llength [info commands testobj]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]
diff --git a/tests/parse.test b/tests/parse.test
index 3523975..0f76d64 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -16,6 +16,9 @@ if {[catch {package require tcltest 2.0.2}]} {
namespace eval ::tcl::test::parse {
namespace import ::tcltest::*
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testparser [llength [info commands testparser]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
testConstraint testevalex [llength [info commands testevalex]]
diff --git a/tests/parseExpr.test b/tests/parseExpr.test
index cd0342a..7910974 100644
--- a/tests/parseExpr.test
+++ b/tests/parseExpr.test
@@ -13,6 +13,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Note that the Tcl expression parser (tclCompExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
# for example, that a math function actually exists, or that the operands
diff --git a/tests/parseOld.test b/tests/parseOld.test
index 132481c..0edcbf0 100644
--- a/tests/parseOld.test
+++ b/tests/parseOld.test
@@ -18,6 +18,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testwordend [llength [info commands testwordend]]
# Save the argv value for restoration later
diff --git a/tests/platform.test b/tests/platform.test
index 92ca7ab..aab7c78 100644
--- a/tests/platform.test
+++ b/tests/platform.test
@@ -14,6 +14,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testCPUID [llength [info commands testcpuid]]
test platform-1.1 {TclpSetVariables: tcl_platform} {
diff --git a/tests/reg.test b/tests/reg.test
index abfc9ca..a0ea850 100644
--- a/tests/reg.test
+++ b/tests/reg.test
@@ -13,6 +13,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# All tests require the testregexp command, return if this
# command doesn't exist
diff --git a/tests/registry.test b/tests/registry.test
index 400277f..77588e3 100644
--- a/tests/registry.test
+++ b/tests/registry.test
@@ -17,13 +17,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
testConstraint reg 0
if {[testConstraint win]} {
- catch {
- # Is the registry extension already static to this shell?
- if [catch {load {} Registry; set ::reglib {}}] {
- # try the location given to use on the commandline to tcltest
+ if {![catch {
::tcltest::loadTestedCommands
- load $::reglib Registry
- }
+ set ::regver [package require registry 1.3.0]
+ }]} {
testConstraint reg 1
}
}
@@ -34,6 +31,9 @@ testConstraint english [expr {
&& [string match "English*" [testlocale all ""]]
}]
+test registry-1.0 {check if we are testing the right dll} {win reg} {
+ set ::regver
+} {1.3.0}
test registry-1.1 {argument parsing for registry command} {win reg} {
list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
@@ -505,7 +505,7 @@ test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} {
registry delete HKEY_CURRENT_USER\\TclFoobar
set result
} "foo ba r baz"
-test registry-6.21 {GetValue: very long value names and values} {pcOnly} {
+test registry-6.21 {GetValue: very long value names and values} {pcOnly reg} {
registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383] [string repeat x 16383] multi_sz
set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383]]
registry delete HKEY_CURRENT_USER\\TclFoobar
diff --git a/tests/rename.test b/tests/rename.test
index 9ac49b4..1fa0441 100644
--- a/tests/rename.test
+++ b/tests/rename.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testdel [llength [info commands testdel]]
# Must eliminate the "unknown" command while the test is running, especially
diff --git a/tests/resolver.test b/tests/resolver.test
index bb9f59d..e73ea50 100644
--- a/tests/resolver.test
+++ b/tests/resolver.test
@@ -15,6 +15,9 @@ if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testinterpresolver [llength [info commands testinterpresolver]]
test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup {
diff --git a/tests/result.test b/tests/result.test
index f080654..3391ce1 100644
--- a/tests/result.test
+++ b/tests/result.test
@@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Some tests require the testsaveresult command
testConstraint testsaveresult [llength [info commands testsaveresult]]
diff --git a/tests/set.test b/tests/set.test
index 9e0ddc0..1d88553 100644
--- a/tests/set.test
+++ b/tests/set.test
@@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testset2 [llength [info commands testset2]]
catch {unset x}
diff --git a/tests/string.test b/tests/string.test
index b3326ae..e86c0de 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Some tests require the testobj command
testConstraint testobj [expr {[info commands testobj] != {}}]
@@ -1773,10 +1776,10 @@ test string-26.3.1 {tcl::prefix, bad args} -body {
} -returnCodes 1 -result {error options must have an even number of elements}
test string-26.3.2 {tcl::prefix, bad args} -body {
tcl::prefix match -error str1 str2
-} -returnCodes 1 -result {missing error options}
+} -returnCodes 1 -result {missing value for -error}
test string-26.4 {tcl::prefix, bad args} -body {
tcl::prefix match -message str1 str2
-} -returnCodes 1 -result {missing message}
+} -returnCodes 1 -result {missing value for -message}
test string-26.5 {tcl::prefix} {
tcl::prefix match {apa bepa cepa depa} cepa
} cepa
diff --git a/tests/stringComp.test b/tests/stringComp.test
index ff18819..56fb69d 100644
--- a/tests/stringComp.test
+++ b/tests/stringComp.test
@@ -20,6 +20,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Some tests require the testobj command
testConstraint testobj [expr {[info commands testobj] != {}}]
diff --git a/tests/stringObj.test b/tests/stringObj.test
index d93bb82..6f331d3 100644
--- a/tests/stringObj.test
+++ b/tests/stringObj.test
@@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testobj [llength [info commands testobj]]
testConstraint testdstring [llength [info commands testdstring]]
diff --git a/tests/tailcall.test b/tests/tailcall.test
index e9ec188..2d04f82 100644
--- a/tests/tailcall.test
+++ b/tests/tailcall.test
@@ -14,6 +14,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testnrelevels [llength [info commands testnrelevels]]
#
diff --git a/tests/thread.test b/tests/thread.test
index 44789fa..f2735da 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Some tests require the testthread command
testConstraint testthread [expr {[info commands testthread] != {}}]
diff --git a/tests/trace.test b/tests/trace.test
index 693dbad..0f48dcf 100644
--- a/tests/trace.test
+++ b/tests/trace.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test
index e8148e9..2453e01 100644
--- a/tests/unixFCmd.test
+++ b/tests/unixFCmd.test
@@ -14,6 +14,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testchmod [llength [info commands testchmod]]
# These tests really need to be run from a writable directory, which
diff --git a/tests/unixFile.test b/tests/unixFile.test
index 0ea0ec1..8147f48 100644
--- a/tests/unixFile.test
+++ b/tests/unixFile.test
@@ -14,6 +14,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testfindexecutable [llength [info commands testfindexecutable]]
set oldpwd [pwd]
diff --git a/tests/unload.test b/tests/unload.test
index a103cc5..5a374c4 100644
--- a/tests/unload.test
+++ b/tests/unload.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Figure out what extension is used for shared libraries on this
# platform.
if {![info exists ext]} {
diff --git a/tests/upvar.test b/tests/upvar.test
index cd78c31..e2c9ffd 100644
--- a/tests/upvar.test
+++ b/tests/upvar.test
@@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testupvar [llength [info commands testupvar]]
test upvar-1.1 {reading variables with upvar} {
diff --git a/tests/utf.test b/tests/utf.test
index fcd2a73..c41cfe3 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -13,6 +13,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
catch {unset x}
test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
diff --git a/tests/util.test b/tests/util.test
index 1da533c..0e50483 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -12,6 +12,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint controversialNaN 1
testConstraint testdstring [llength [info commands testdstring]]
testConstraint testconcatobj [llength [info commands testconcatobj]]
diff --git a/tests/var.test b/tests/var.test
index f2923de..ed7e930 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -19,6 +19,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testupvar [llength [info commands testupvar]]
testConstraint testgetvarfullname [llength [info commands testgetvarfullname]]
testConstraint testsetnoerr [llength [info commands testsetnoerr]]
diff --git a/tests/winDde.test b/tests/winDde.test
index 83f3598..8d9bd12 100644
--- a/tests/winDde.test
+++ b/tests/winDde.test
@@ -15,16 +15,15 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
-if [catch {
- # Is the dde extension already static to this shell?
- if [catch {load {} Dde; set ::ddelib {}}] {
- # try the location given to use on the commandline to tcltest
- ::tcltest::loadTestedCommands
- load $::ddelib Dde
+testConstraint debug [::tcl::pkgconfig get debug]
+testConstraint dde 0
+if {[testConstraint win]} {
+ if {![catch {
+ ::tcltest::loadTestedCommands
+ set ::ddever [package require dde 1.4.0b1]
+ set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} {
+ testConstraint dde 1
}
- testConstraint dde 1
-}] {
- testConstraint dde 0
}
@@ -39,9 +38,7 @@ proc createChildProcess {ddeServerName args} {
set f [open $::scriptName w+]
puts $f [list set ddeServerName $ddeServerName]
- if {$::ddelib != ""} {
- puts $f [list load $::ddelib Dde]
- }
+ puts $f [list load $::ddelib dde]
puts $f {
# DDE child server -
#
@@ -105,6 +102,9 @@ proc createChildProcess {ddeServerName args} {
}
# -------------------------------------------------------------------------
+test winDde-1.0 {check if we are testing the right dll} {win dde} {
+ set ::ddever
+} {1.4.0b1}
test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
list [dde servername foobar] [dde servername] [dde servername self]
@@ -140,33 +140,43 @@ test winDde-3.2 {DDE execute -async locally} -constraints dde -body {
set \xe1
} -result foo
test winDde-3.3 {DDE request locally} -constraints dde -body {
- set a ""
- dde execute TclEval self [list set a foo]
- dde request TclEval self a
+ set \xe1 ""
+ dde execute TclEval self [list set \xe1 foo]
+ dde request TclEval self \xe1
} -result foo
test winDde-3.4 {DDE eval locally} -constraints dde -body {
set \xe1 ""
dde eval self set \xe1 foo
} -result foo
test winDde-3.5 {DDE request locally} -constraints dde -body {
- set a ""
- dde execute TclEval self [list set a foo]
- dde request -binary TclEval self a
+ set \xe1 ""
+ dde execute TclEval self [list set \xe1 foo]
+ dde request -binary TclEval self \xe1
} -result "foo\x00"
# Set variable a to A with diaeresis (unicode C4) by relying on the fact
# that utf8 is sent (e.g. "c3 84" on the wire)
test winDde-3.6 {DDE request utf8} -constraints dde -body {
- set a "not set"
- dde execute TclEval self "set a \xc4"
- scan $a %c
+ set \xe1 "not set"
+ dde execute TclEval self "set \xe1 \xc4"
+ scan [set \xe1] %c
} -result 196
# Set variable a to A with diaeresis (unicode C4) using binary execute
# and compose utf-8 (e.g. "c3 84" ) manualy
test winDde-3.7 {DDE request binary} -constraints dde -body {
- set a "not set"
- dde execute -binary TclEval self [list set a \xc3\x84\x00]
- scan $a %c
+ set \xe1 "not set"
+ dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00]
+ scan [set \xe1] %c
} -result 196
+test winDde-3.8 {DDE poke locally} -constraints {dde debug} -body {
+ set \xe1 ""
+ dde poke TclEval self \xe1 \xc4
+ dde request TclEval self \xe1
+} -result \xc4
+test winDde-3.9 {DDE poke -binary locally} -constraints {dde debug} -body {
+ set \xe1 ""
+ dde poke -binary TclEval self \xe1 \xc3\x84\x00
+ dde request TclEval self \xe1
+} -result \xc4
# -------------------------------------------------------------------------
@@ -190,24 +200,34 @@ test winDde-4.2 {DDE execute async remotely} -constraints {dde stdio} -body {
set \xe1
} -result ""
test winDde-4.3 {DDE request remotely} -constraints {dde stdio} -body {
- set a ""
+ set \xe1 ""
set name ch\xEDld-4.3
set child [createChildProcess $name]
dde execute TclEval $name [list set a foo]
- set a [dde request TclEval $name a]
+ set \xe1 [dde request TclEval $name a]
dde execute TclEval $name {set done 1}
update
- set a
+ set \xe1
} -result foo
test winDde-4.4 {DDE eval remotely} -constraints {dde stdio} -body {
- set a ""
+ set \xe1 ""
set name ch\xEDld-4.4
set child [createChildProcess $name]
- set a [dde eval $name set a foo]
+ set \xe1 [dde eval $name set \xe1 foo]
dde execute TclEval $name {set done 1}
update
- set a
+ set \xe1
} -result foo
+test winDde-4.5 {DDE poke remotely} -constraints {dde debug stdio} -body {
+ set \xe1 ""
+ set name ch\xEDld-4.5
+ set child [createChildProcess $name]
+ dde poke TclEval $name \xe1 foo
+ set \xe1 [dde request TclEval $name \xe1]
+ dde execute TclEval $name {set done 1}
+ update
+ set \xe1
+} -result foo
# -------------------------------------------------------------------------
diff --git a/tests/winFCmd.test b/tests/winFCmd.test
index b49356d..28a0e9f 100644
--- a/tests/winFCmd.test
+++ b/tests/winFCmd.test
@@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Initialise the test constraints
testConstraint winVista 0
diff --git a/tests/winFile.test b/tests/winFile.test
index ad34624..fba9bcb 100644
--- a/tests/winFile.test
+++ b/tests/winFile.test
@@ -16,6 +16,9 @@ if {[catch {package require tcltest 2.0.2}]} {
}
namespace import -force ::tcltest::*
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint notNTFS 0
testConstraint win2000 0
diff --git a/tests/winNotify.test b/tests/winNotify.test
index f9c75a3..3e9aa29 100644
--- a/tests/winNotify.test
+++ b/tests/winNotify.test
@@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testeventloop [expr {[info commands testeventloop] != {}}]
# There is no explicit test for InitNotifier or NotifierExitHandler
diff --git a/tests/winPipe.test b/tests/winPipe.test
index 62d7d0d..d2e804d 100644
--- a/tests/winPipe.test
+++ b/tests/winPipe.test
@@ -16,6 +16,12 @@ package require tcltest
namespace import -force ::tcltest::*
unset -nocomplain path
+catch {
+ ::tcltest::loadTestedCommands
+ package require -exact Tcltest [info patchlevel]
+ set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
+}
+
set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
set cat32 [file join $bindir cat32.exe]
@@ -23,6 +29,8 @@ testConstraint exec [llength [info commands exec]]
testConstraint cat32 [file exists $cat32]
testConstraint AllocConsole [catch {puts console1 ""}]
testConstraint RealConsole [expr {![testConstraint AllocConsole]}]
+testConstraint testexcept [llength [info commands testexcept]]
+
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
append big $big
@@ -190,30 +198,34 @@ test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} {
vwait x
list $result $x [contents $path(stderr)]
} "{$big} 1 stderr32"
-test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec} {
+test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
+ puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept float_underflow"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGFPE}
-test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec} {
+test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
+ puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept access_violation"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGSEGV}
-test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec} {
+test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
+ puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept illegal_instruction"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGILL}
-test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec} {
+test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec testexcept} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
+ puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept ctrl+c"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
diff --git a/tests/winTime.test b/tests/winTime.test
index 278db32..add8f98 100644
--- a/tests/winTime.test
+++ b/tests/winTime.test
@@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
testConstraint testwinclock [llength [info commands testwinclock]]
# The next two tests will crash on Windows if the check for negative