summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/all.tcl2
-rw-r--r--tests/binary.test13
-rw-r--r--tests/case.test5
-rw-r--r--tests/clock.test4
-rw-r--r--tests/cmdMZ.test2
-rw-r--r--tests/expr.test9
-rw-r--r--tests/fCmd.test16
-rw-r--r--tests/format.test7
-rw-r--r--tests/get.test22
-rw-r--r--tests/history.test58
-rw-r--r--tests/http.test8
-rw-r--r--tests/httpd4
-rw-r--r--tests/httpd11.tcl2
-rw-r--r--tests/info.test4
-rw-r--r--tests/link.test84
-rw-r--r--tests/main.test2
-rw-r--r--tests/msgcat.test2
-rw-r--r--tests/obj.test13
-rw-r--r--tests/package.test2
-rw-r--r--tests/registry.test8
-rw-r--r--tests/result.test4
-rw-r--r--tests/safe.test2
-rw-r--r--tests/scan.test6
-rw-r--r--tests/set-old.test7
-rw-r--r--tests/socket.test43
-rw-r--r--tests/string.test8
-rw-r--r--tests/stringComp.test3
-rw-r--r--tests/tm.test2
-rw-r--r--tests/util.test25
-rw-r--r--tests/winFCmd.test72
-rw-r--r--tests/winFile.test18
-rw-r--r--tests/winPipe.test6
-rw-r--r--tests/zlib.test19
33 files changed, 380 insertions, 102 deletions
diff --git a/tests/all.tcl b/tests/all.tcl
index 0a6f57f..69a16ba 100644
--- a/tests/all.tcl
+++ b/tests/all.tcl
@@ -11,7 +11,7 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package prefer latest
-package require Tcl 8.5
+package require Tcl 8.5-
package require tcltest 2.2
namespace import tcltest::*
configure {*}$argv -testdir [file dir [info script]]
diff --git a/tests/binary.test b/tests/binary.test
index 40b1315..7738f69 100644
--- a/tests/binary.test
+++ b/tests/binary.test
@@ -2837,6 +2837,19 @@ test binary-76.2 {binary string appending growth algorithm} win {
# Append to it
string length [append str [binary format a* foo]]
} 3
+
+test binary-77.1 {string cat ops on all bytearrays} {
+ apply {{a b} {
+ return [binary format H* $a][binary format H* $b]
+ }} ab cd
+} [binary format H* abcd]
+test binary-77.2 {string cat ops on all bytearrays} {
+ apply {{a b} {
+ set one [binary format H* $a]
+ return $one[binary format H* $b]
+ }} ab cd
+} [binary format H* abcd]
+
# ----------------------------------------------------------------------
# cleanup
diff --git a/tests/case.test b/tests/case.test
index 6d63cea..d7558a9 100644
--- a/tests/case.test
+++ b/tests/case.test
@@ -11,6 +11,11 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+if {![llength [info commands case]]} {
+ # No "case" command? So no need to test
+ return
+}
+
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
diff --git a/tests/clock.test b/tests/clock.test
index 08036ca..6a0fecd 100644
--- a/tests/clock.test
+++ b/tests/clock.test
@@ -37009,10 +37009,10 @@ test clock-67.5 {Change scan %x output on global locale change [Bug 4a0c163d24]}
set current [msgcat::mclocale]
} -body {
msgcat::mclocale de_de
- set res [clock scan "01.01.1970" -locale current -format %x]
+ set res [clock scan "01.01.1970" -locale current -format %x -gmt 1]
msgcat::mclocale en_uk
# This will fail without the bug fix, as still de_de is active
- expr {$res == [clock scan "01/01/1970" -locale current -format %x]}
+ expr {$res == [clock scan "01/01/1970" -locale current -format %x -gmt 1]}
} -cleanup {
msgcat::mclocale $current
} -result {1}
diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test
index 2d68138..a5f3009 100644
--- a/tests/cmdMZ.test
+++ b/tests/cmdMZ.test
@@ -234,7 +234,7 @@ test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints {
test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints {
unixOrPc
} -returnCodes error -body {
- source a b
+ source a b c d e f
} -match glob -result {wrong # args: should be "source*fileName"}
test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body {
set file [makeFile {
diff --git a/tests/expr.test b/tests/expr.test
index 4046411..8e083c5 100644
--- a/tests/expr.test
+++ b/tests/expr.test
@@ -910,6 +910,15 @@ test expr-22.9 {non-numeric floats: shared object equality and NaN} {
set x NaN
expr {$x == $x}
} 0
+# Make sure [Bug d0f7ba56f0] stays fixed.
+test expr-22.10 {non-numeric arguments: equality and NaN} {
+ set x NaN
+ expr {$x > "Gran"}
+} 1
+test expr-22.11 {non-numeric arguments: equality and NaN} {
+ set x NaN
+ expr {"Gran" < $x}
+} 1
# Tests for exponentiation handling
test expr-23.1 {CompileExponentialExpr: just exponential expr} {expr 4**2} 16
diff --git a/tests/fCmd.test b/tests/fCmd.test
index c8264b2..709bfb4 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -23,7 +23,7 @@ cd [temporaryDirectory]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint winVista 0
-testConstraint win2000orXP 0
+testConstraint winXP 0
# Don't know how to determine this constraint correctly
testConstraint notNetworkFilesystem 0
testConstraint reg 0
@@ -66,12 +66,10 @@ if {[testConstraint unix]} {
# Also used in winFCmd...
if {[testConstraint win]} {
set major [string index $tcl_platform(osVersion) 0]
- if {[testConstraint nt] && $major > 4} {
- if {$major > 5} {
- testConstraint winVista 1
- } elseif {$major == 5} {
- testConstraint win2000orXP 1
- }
+ if {$major > 5} {
+ testConstraint winVista 1
+ } else {
+ testConstraint winXP 1
}
}
@@ -792,7 +790,7 @@ test fCmd-9.3 {file rename: comprehensive: file to new name} -setup {
} -result {{tf3 tf4} 1 0}
test fCmd-9.4.a {file rename: comprehensive: dir to new name} -setup {
cleanup
-} -constraints {win win2000orXP testchmod} -body {
+} -constraints {win testchmod} -body {
file mkdir td1 td2
testchmod 0o555 td2
file rename td1 td3
@@ -824,7 +822,7 @@ test fCmd-9.5 {file rename: comprehensive: file to self} -setup {
} -result {tf1 tf2 1 0}
test fCmd-9.6.a {file rename: comprehensive: dir to self} -setup {
cleanup
-} -constraints {win win2000orXP testchmod} -body {
+} -constraints {win winXP testchmod} -body {
file mkdir td1
file mkdir td2
testchmod 0o555 td2
diff --git a/tests/format.test b/tests/format.test
index 27eac31..e199398 100644
--- a/tests/format.test
+++ b/tests/format.test
@@ -564,9 +564,12 @@ test format-19.3 {Bug 2830354} {
test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body {
set x [dict create a b c d]
format %s $x
- # After this, obj in $x should be a dict with a non-NULL bytes field
+ # After this, obj in $x should be a dict
+ # We are testing to make sure it has not been shimmered to a
+ # different intrep when that is not necessary.
+ # Whether or not there is a string rep - we should not care!
tcl::unsupported::representation $x
-} -match glob -result {value is a dict with *, string representation "*"}
+} -match glob -result {value is a dict *}
# cleanup
catch {unset a}
diff --git a/tests/get.test b/tests/get.test
index d51ec6d..7aa06c1 100644
--- a/tests/get.test
+++ b/tests/get.test
@@ -19,9 +19,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testgetint [llength [info commands testgetint]]
+testConstraint testdoubleobj [llength [info commands testdoubleobj]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
-
+
test get-1.1 {Tcl_GetInt procedure} testgetint {
testgetint 44 { 22}
} {66}
@@ -95,7 +96,24 @@ test get-3.2 {Tcl_GetDouble(FromObj), bad numbers} {
}
set result
} {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got "- +1.0"}}
-
+# Bug 7114ac6141
+test get-3.3 {tcl_GetInt with iffy numbers} testgetint {
+ lmap x {0 " 0" "0 " " 0 " " 0xa " " 010 " " 0o10 " " 0b10 "} {
+ catch {testgetint 44 $x} x
+ set x
+ }
+} {44 44 44 44 54 52 52 46}
+test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj {
+ lmap x {0 0.0 " .0" ".0 " " 0e0 " "09" "- 0" "-0" "0o12" "0b10"} {
+ catch {testdoubleobj set 1 $x} x
+ set x
+ }
+} {0.0 0.0 0.0 0.0 0.0 {expected floating-point number but got "09" (looks like invalid octal number)} {expected floating-point number but got "- 0"} 0.0 10.0 2.0}
+
# cleanup
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/history.test b/tests/history.test
index c2d2124..9ff41f2 100644
--- a/tests/history.test
+++ b/tests/history.test
@@ -11,8 +11,8 @@
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2
namespace import -force ::tcltest::*
}
@@ -245,6 +245,60 @@ test history-9.2 {miscellaneous} history {
catch {history gorp} msg
set msg
} {unknown or ambiguous subcommand "gorp": must be add, change, clear, event, info, keep, nextid, or redo}
+
+# History retains references; Bug 1ae12987cb
+test history-10.1 {references kept by history} -constraints history -setup {
+ interp create histtest
+ histtest eval {
+ # Trigger any autoloading that might be present
+ catch {history}
+ proc refcount {x} {
+ set rep [::tcl::unsupported::representation $x]
+ regexp {with a refcount of (\d+)} $rep -> rc
+ # Ignore the references due to calling this procedure
+ return [expr {$rc - 3}]
+ }
+ }
+} -body {
+ histtest eval {
+ # A fresh object, refcount 1 from the variable we write it to
+ set obj [expr rand()]
+ set baseline [refcount $obj]
+ lappend result [refcount $obj]
+ history add [list list $obj]
+ lappend result [refcount $obj]
+ history clear
+ lappend result [refcount $obj]
+ }
+} -cleanup {
+ interp delete histtest
+} -result {1 2 1}
+test history-10.2 {references kept by history} -constraints history -setup {
+ interp create histtest
+ histtest eval {
+ # Trigger any autoloading that might be present
+ catch {history}
+ proc refcount {x} {
+ set rep [::tcl::unsupported::representation $x]
+ regexp {with a refcount of (\d+)} $rep -> rc
+ # Ignore the references due to calling this procedure
+ return [expr {$rc - 3}]
+ }
+ }
+} -body {
+ histtest eval {
+ # A fresh object, refcount 1 from the variable we write it to
+ set obj [expr rand()]
+ set baseline [refcount $obj]
+ lappend result [refcount $obj]
+ history add [list list $obj]
+ lappend result [refcount $obj]
+ rename history {}
+ lappend result [refcount $obj]
+ }
+} -cleanup {
+ interp delete histtest
+} -result {1 2 1}
# cleanup
::tcltest::cleanupTests
diff --git a/tests/http.test b/tests/http.test
index 41820cb..12ad475 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -133,6 +133,7 @@ set tail /a/b/c
set url //[info hostname]:$port/a/b/c
set fullurl HTTP://user:pass@[info hostname]:$port/a/b/c
set binurl //[info hostname]:$port/binary
+set xmlurl //[info hostname]:$port/xml
set posturl //[info hostname]:$port/post
set badposturl //[info hostname]:$port/droppost
set authorityurl //[info hostname]:$port
@@ -431,6 +432,13 @@ Accept text/plain,application/tcl-test-value
Accept-Encoding .*
Content-Type application/x-www-form-urlencoded
Content-Length 5}
+# Bug 838e99a76d
+test http-3.33 {http::geturl application/xml is text} -body {
+ set token [http::geturl "$xmlurl"]
+ scan [http::data $token] "<%\[^>]>%c<%\[^>]>"
+} -cleanup {
+ catch { http::cleanup $token }
+} -result {test 4660 /test}
test http-4.1 {http::Event} -body {
set token [http::geturl $url -keepalive 0]
diff --git a/tests/httpd b/tests/httpd
index c934fac..40e10df 100644
--- a/tests/httpd
+++ b/tests/httpd
@@ -171,6 +171,10 @@ proc httpdRespond { sock } {
set html "$bindata[info hostname]:$port$data(url)"
set type application/octet-stream
}
+ *xml* {
+ set html [encoding convertto utf-8 "<test>\u1234</test>"]
+ set type "application/xml;charset=UTF-8"
+ }
*post* {
set html "Got [string length $data(query)] bytes"
set type text/plain
diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl
index 6eae2b7..7880494 100644
--- a/tests/httpd11.tcl
+++ b/tests/httpd11.tcl
@@ -8,7 +8,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-package require Tcl 8.6
+package require Tcl 8.6-
proc ::tcl::dict::get? {dict key} {
if {[dict exists $dict $key]} {
diff --git a/tests/info.test b/tests/info.test
index a6a5919..fd89b47 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -397,8 +397,8 @@ test info-10.3 {info library option} -body {
set tcl_library $savedLibrary; unset savedLibrary
test info-11.1 {info loaded option} -body {
- info loaded a b
-} -returnCodes error -result {wrong # args: should be "info loaded ?interp?"}
+ info loaded a b c
+} -returnCodes error -result {wrong # args: should be "info loaded ?interp? ?packageName?"}
test info-11.2 {info loaded option} -body {
info loaded {}; info loaded gorp
} -returnCodes error -result {could not find interpreter "gorp"}
diff --git a/tests/link.test b/tests/link.test
index 00e490c..dda7d6b 100644
--- a/tests/link.test
+++ b/tests/link.test
@@ -89,6 +89,90 @@ test link-2.5 {writing bad values into variables} -setup {
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
list [catch {set wide gorp} msg] $msg $bool
} -result {1 {can't set "wide": variable must have integer value} 1}
+test link-2.6 {writing C variables from Tcl} -constraints {testlink} -setup {
+ testlink delete
+} -body {
+ testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234
+ testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ set int "+"
+ set real "+"
+ set bool 1
+ set string "+"
+ set wide "+"
+ set char "+"
+ set uchar "+"
+ set short "+"
+ set ushort "+"
+ set uint "+"
+ set long "+"
+ set ulong "+"
+ set float "+"
+ set uwide "+"
+ concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
+} -result {1 1.0 1 + 1 1 1 1 1 1 1 1 1.0 1 | + + 1 + + + + + + + + + + +}
+test link-2.7 {writing C variables from Tcl} -constraints {testlink} -setup {
+ testlink delete
+} -body {
+ testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234
+ testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ set int "-"
+ set real "-"
+ set bool 0
+ set string "-"
+ set wide "-"
+ set char "-"
+ set uchar "-"
+ set short "-"
+ set ushort "-"
+ set uint "-"
+ set long "-"
+ set ulong "-"
+ set float "-"
+ set uwide "-"
+ concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
+} -result {0 0.0 0 - 0 0 0 0 0 0 0 0 0.0 0 | - - 0 - - - - - - - - - - -}
+test link-2.8 {writing C variables from Tcl} -constraints {testlink} -setup {
+ testlink delete
+} -body {
+ testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234
+ testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ set int "0x"
+ set real "0b"
+ set bool 0
+ set string "0"
+ set wide "0O"
+ set char "0X"
+ set uchar "0B"
+ set short "0O"
+ set ushort "0x"
+ set uint "0b"
+ set long "0o"
+ set ulong "0X"
+ set float "0B"
+ set uwide "0O"
+ concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
+} -result {0 0.0 0 0 0 0 0 0 0 0 0 0 0.0 0 | 0x 0b 0 0 0O 0X 0B 0O 0x 0b 0o 0X 0B 0O}
+test link-2.8 {writing C variables from Tcl} -constraints {testlink} -setup {
+ testlink delete
+} -body {
+ testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234
+ testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ set int 0
+ set real 5000e
+ set bool 0
+ set string 0
+ set wide 0
+ set char 0
+ set uchar 0
+ set short 0
+ set ushort 0
+ set uint 0
+ set long 0
+ set ulong 0
+ set float -60.00e+
+ set uwide 0
+ concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
+} -result {0 5000.0 0 0 0 0 0 0 0 0 0 0 -60.0 0 | 0 5000e 0 0 0 0 0 0 0 0 0 0 -60.00e+ 0}
test link-3.1 {read-only variables} -constraints {testlink} -setup {
testlink delete
diff --git a/tests/main.test b/tests/main.test
index 96af066..ab66b38 100644
--- a/tests/main.test
+++ b/tests/main.test
@@ -16,7 +16,7 @@ namespace eval ::tcl::test::main {
# - tests use testing commands introduced in Tcltest 8.4
testConstraint Tcltest [expr {
[llength [package provide Tcltest]]
- && [package vsatisfies [package provide Tcltest] 8.4]}]
+ && [package vsatisfies [package provide Tcltest] 8.5-]}]
# Procedure to simulate interactive typing of commands, line by line
proc type {chan script} {
diff --git a/tests/msgcat.test b/tests/msgcat.test
index e69220e..1c3ce58 100644
--- a/tests/msgcat.test
+++ b/tests/msgcat.test
@@ -12,7 +12,7 @@
# Note that after running these tests, entries will be left behind in the
# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
-package require Tcl 8.5
+package require Tcl 8.5-
if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
diff --git a/tests/obj.test b/tests/obj.test
index a8d2d20..833c906 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -625,6 +625,19 @@ test obj-33.7 {integer overflow on input} {
list [string is integer $x] [expr { wide($x) }]
} {0 -4294967296}
+test obj-34.1 {mp_iseven} testobj {
+ set result ""
+ lappend result [testbignumobj set 1 0]
+ lappend result [testbignumobj iseven 1] ;
+ lappend result [testobj type 1]
+} {0 1 int}
+test obj-34.2 {mp_radix_size} testobj {
+ set result ""
+ lappend result [testbignumobj set 1 9]
+ lappend result [testbignumobj radixsize 1] ;
+ lappend result [testobj type 1]
+} {9 2 int}
+
if {[testConstraint testobj]} {
testobj freeallvars
}
diff --git a/tests/package.test b/tests/package.test
index 49346d8..99f9f06 100644
--- a/tests/package.test
+++ b/tests/package.test
@@ -832,7 +832,7 @@ test package-4.52 {Tcl_PackageCmd procedure, "vsatisfies" option} {
} {0}
test package-4.53 {Tcl_PackageCmd procedure, "versions" option} -body {
package foo
-} -returnCodes error -result {bad option "foo": must be forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies}
+} -returnCodes error -result {bad option "foo": must be files, forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies}
test package-4.54 {Tcl_PackageCmd procedure, "vsatisfies" option} -body {
package vsatisfies 2.1 2.1-3.2-4.5
} -returnCodes error -result {expected versionMin-versionMax but got "2.1-3.2-4.5"}
diff --git a/tests/registry.test b/tests/registry.test
index 2072559..fec4cc0 100644
--- a/tests/registry.test
+++ b/tests/registry.test
@@ -283,7 +283,7 @@ test registry-4.7 {GetKeyNames: Unicode} {win reg english} {
registry delete HKEY_CURRENT_USER\\TclFoobar
set result
} "baz\u00c7bar blat"
-test registry-4.8 {GetKeyNames: Unicode} {win reg nt} {
+test registry-4.8 {GetKeyNames: Unicode} {win reg} {
registry delete HKEY_CURRENT_USER\\TclFoobar
registry set HKEY_CURRENT_USER\\TclFoobar\\baz\u30b7bar
registry set HKEY_CURRENT_USER\\TclFoobar\\blat
@@ -487,7 +487,7 @@ test registry-6.17 {GetValue: Unicode value names} {win reg} {
registry delete HKEY_CURRENT_USER\\TclFoobar
set result
} foobar
-test registry-6.18 {GetValue: values with Unicode strings} {win reg nt} {
+test registry-6.18 {GetValue: values with Unicode strings} {win reg} {
registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u30b7r baz} multi_sz
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
registry delete HKEY_CURRENT_USER\\TclFoobar
@@ -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 reg} {
+test registry-6.21 {GetValue: very long value names and values} {win 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
@@ -604,7 +604,7 @@ test registry-9.3 {ParseKeyName: bad keys} -constraints {win reg} -body {
test registry-9.4 {ParseKeyName: bad keys} -constraints {win reg} -body {
registry values \\\\\\
} -returnCodes error -result {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}
-test registry-9.5 {ParseKeyName: bad keys} -constraints {win reg english nt} -body {
+test registry-9.5 {ParseKeyName: bad keys} -constraints {win reg english} -body {
registry values \\\\\\HKEY_CLASSES_ROOT
} -returnCodes error -result {unable to open key: The network address is invalid.}
test registry-9.6 {ParseKeyName: bad keys} -constraints {win reg} -body {
diff --git a/tests/result.test b/tests/result.test
index 9e8a66b..859e546 100644
--- a/tests/result.test
+++ b/tests/result.test
@@ -31,7 +31,7 @@ test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} {
} {append result}
test result-1.3 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult dynamic {set x 42} 0
-} {dynamic result notCalled present}
+} {dynamic result presentOrFreed}
test result-1.4 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult object {set x 42} 0
} {object result same}
@@ -43,7 +43,7 @@ test result-1.6 {Tcl_SaveInterpResult} {testsaveresult} {
} {42}
test result-1.7 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult dynamic {set x 42} 1
-} {42 called missing}
+} {42 presentOrFreed}
test result-1.8 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult object {set x 42} 1
} {42 different}
diff --git a/tests/safe.test b/tests/safe.test
index 6c9c6c9..e43ce12 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
-package require Tcl 8.5
+package require Tcl 8.5-
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
diff --git a/tests/scan.test b/tests/scan.test
index b57b641..7540c9c 100644
--- a/tests/scan.test
+++ b/tests/scan.test
@@ -535,6 +535,12 @@ test scan-5.13 {integer scanning and overflow} {
test scan-5.14 {integer scanning} {
scan 0xff %u
} 0
+test scan-5.15 {Bug be003d570f} {
+ scan 0x40 %o
+} 0
+test scan-5.16 {Bug be003d570f} {
+ scan 0x40 %b
+} 0
test scan-6.1 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
diff --git a/tests/set-old.test b/tests/set-old.test
index 93169f1..309abaf 100644
--- a/tests/set-old.test
+++ b/tests/set-old.test
@@ -652,6 +652,13 @@ test set-old-8.52 {array command, array names -regexp on regexp pattern} {
set a(11) 1
list [catch {lsort [array names a -regexp ^1]} msg] $msg
} {0 {1*2 11 12}}
+test set-old-8.52.1 {array command, array names -regexp, backrefs} {
+ catch {unset a}
+ set a(1*2) 1
+ set a(12) 1
+ set a(11) 1
+ list [catch {lsort [array names a -regexp {^(.)\1}]} msg] $msg
+} {0 11}
test set-old-8.53 {array command, array names -regexp} {
catch {unset a}
set a(-glob) 1
diff --git a/tests/socket.test b/tests/socket.test
index d43c41c..80b0251 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -265,13 +265,13 @@ test socket_$af-1.1 {arg parsing for socket command} -constraints [list socket s
} -returnCodes error -result {no argument given for -server option}
test socket_$af-1.2 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -server foo
-} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
+} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"}
test socket_$af-1.3 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -myaddr
} -returnCodes error -result {no argument given for -myaddr option}
test socket_$af-1.4 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -myaddr $localhost
-} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
+} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"}
test socket_$af-1.5 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -myport
} -returnCodes error -result {no argument given for -myport option}
@@ -280,19 +280,19 @@ test socket_$af-1.6 {arg parsing for socket command} -constraints [list socket s
} -returnCodes error -result {expected integer but got "xxxx"}
test socket_$af-1.7 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -myport 2522
-} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
+} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"}
test socket_$af-1.8 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -froboz
-} -returnCodes error -result {bad option "-froboz": must be -async, -myaddr, -myport, or -server}
+} -returnCodes error -result {bad option "-froboz": must be -async, -myaddr, -myport, -reuseaddr, -reuseport, or -server}
test socket_$af-1.9 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -server foo -myport 2521 3333
} -returnCodes error -result {option -myport is not valid for servers}
test socket_$af-1.10 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket host 2528 -junk
-} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
+} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"}
test socket_$af-1.11 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -server callback 2520 --
-} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
+} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"}
test socket_$af-1.12 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket foo badport
} -returnCodes error -result {expected integer but got "badport"}
@@ -302,6 +302,24 @@ test socket_$af-1.13 {arg parsing for socket command} -constraints [list socket
test socket_$af-1.14 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -server foo -async
} -returnCodes error -result {cannot set -async option for server sockets}
+test socket_$af-1.15 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
+ socket -reuseaddr yes 4242
+} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers}
+test socket_$af-1.16 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
+ socket -reuseaddr no 4242
+} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers}
+test socket_$af-1.17 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
+ socket -reuseaddr
+} -returnCodes error -result {no argument given for -reuseaddr option}
+test socket_$af-1.18 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
+ socket -reuseport yes 4242
+} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers}
+test socket_$af-1.19 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
+ socket -reuseport no 4242
+} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers}
+test socket_$af-1.20 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
+ socket -reuseport
+} -returnCodes error -result {no argument given for -reuseport option}
set path(script) [makeFile {} script]
@@ -2360,6 +2378,19 @@ test socket-14.18 {bug c6ed4acfd8: running async socket connect made other conne
catch {close $csock2}
} -result {}
+test socket-14.19 {tip 456 -- introduce the -reuseport option} \
+ -constraints {socket} \
+ -body {
+ proc accept {channel address port} {}
+ set port [randport]
+ set ssock1 [socket -server accept -reuseport yes $port]
+ set ssock2 [socket -server accept -reuseport yes $port]
+ return ok
+} -cleanup {
+ catch {close $ssock1}
+ catch {close $ssock2}
+ } -result ok
+
set num 0
set x {localhost {socket} 127.0.0.1 {supported_inet} ::1 {supported_inet6}}
diff --git a/tests/string.test b/tests/string.test
index 418bc61..11cbcff 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -756,13 +756,13 @@ catch {rename largest_int {}}
test string-7.1 {string last, too few args} {
list [catch {string last a} msg] $msg
-} {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}}
+} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}}
test string-7.2 {string last, bad args} {
list [catch {string last a b c} msg] $msg
} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}}
test string-7.3 {string last, too many args} {
list [catch {string last a b c d} msg] $msg
-} {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}}
+} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}}
test string-7.4 {string last} {
string la xxx xxxx123xx345x678
} 1
@@ -901,6 +901,10 @@ test string-10.20 {string map, dictionaries don't alter map ordering} {
set map {aa X a Y}
list [string map [dict create aa X a Y] aaa] [string map $map aaa] [dict size $map] [string map $map aaa]
} {XY XY 2 XY}
+test string-10.20.1 {string map, dictionaries don't alter map ordering} {
+ set map {a X b Y a Z}
+ list [string map [dict create a X b Y a Z] aaa] [string map $map aaa] [dict size $map] [string map $map aaa]
+} {ZZZ XXX 2 XXX}
test string-10.21 {string map, ABR checks} {
string map {longstring foob} long
} long
diff --git a/tests/stringComp.test b/tests/stringComp.test
index 140a270..2aeb08e 100644
--- a/tests/stringComp.test
+++ b/tests/stringComp.test
@@ -738,6 +738,9 @@ test stringComp-14.4 {Bug 1af8de570511} {
string replace $val[unset val] 1 1 $y
}} 4 x
} 0x00
+test stringComp-14.5 {} {
+ string length [string replace [string repeat a\u00fe 2] 3 end {}]
+} 3
## string tolower
## not yet bc
diff --git a/tests/tm.test b/tests/tm.test
index a4dafe0..567d351 100644
--- a/tests/tm.test
+++ b/tests/tm.test
@@ -6,7 +6,7 @@
# Copyright (c) 2004 by Donal K. Fellows.
# All rights reserved.
-package require Tcl 8.5
+package require Tcl 8.5-
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
diff --git a/tests/util.test b/tests/util.test
index 2ac11bf..1a3eecb 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -20,6 +20,7 @@ testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testdstring [llength [info commands testdstring]]
testConstraint testconcatobj [llength [info commands testconcatobj]]
testConstraint testdoubledigits [llength [info commands testdoubledigits]]
+testConstraint testprint [llength [info commands testprint]]
# Big test for correct ordering of data in [expr]
@@ -4017,6 +4018,30 @@ test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} {
0x4400000000000000 0xc400000000000000
}]
+test util-18.1 {Tcl_ObjPrintf} {testprint} {
+ testprint %lld [expr 2**63-1]
+} {9223372036854775807}
+
+test util-18.2 {Tcl_ObjPrintf} {testprint} {
+ testprint %I64d [expr 2**63-1]
+} {9223372036854775807}
+
+test util-18.3 {Tcl_ObjPrintf} {testprint} {
+ testprint %Ld [expr 2**63-1]
+} {9223372036854775807}
+
+test util-18.4 {Tcl_ObjPrintf} {testprint} {
+ testprint %lld [expr -2**63]
+} {-9223372036854775808}
+
+test util-18.5 {Tcl_ObjPrintf} {testprint} {
+ testprint %I64d [expr -2**63]
+} {-9223372036854775808}
+
+test util-18.6 {Tcl_ObjPrintf} {testprint} {
+ testprint %Ld [expr -2**63]
+} {-9223372036854775808}
+
set ::tcl_precision $saved_precision
# cleanup
diff --git a/tests/winFCmd.test b/tests/winFCmd.test
index a808c82..294745c 100644
--- a/tests/winFCmd.test
+++ b/tests/winFCmd.test
@@ -21,8 +21,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
# Initialise the test constraints
testConstraint winVista 0
-testConstraint win2000orXP 0
-testConstraint winOlderThan2000 0
+testConstraint winXP 0
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint testfile [llength [info commands testfile]]
testConstraint testchmod [llength [info commands testchmod]]
@@ -56,16 +55,12 @@ proc cleanup {args} {
}
}
-if {[testConstraint winOnly]} {
+if {[testConstraint win]} {
set major [string index $tcl_platform(osVersion) 0]
- if {[testConstraint nt] && $major > 4} {
- if {$major > 5} {
- testConstraint winVista 1
- } elseif {$major == 5} {
- testConstraint win2000orXP 1
- }
- } else {
- testConstraint winOlderThan2000 1
+ if {$major > 5} {
+ testConstraint winVista 1
+ } elseif {$major == 5} {
+ testConstraint winXP 1
}
}
@@ -205,17 +200,12 @@ test winFCmd-1.12 {TclpRenameFile: errno: EACCES} -setup {
} -returnCodes error -result EACCES
test winFCmd-1.13 {TclpRenameFile: errno: EACCES} -setup {
cleanup
-} -constraints {win win2000orXP testfile} -body {
+} -constraints {win winXP testfile} -body {
testfile mv nul tf1
} -returnCodes error -result EINVAL
-test winFCmd-1.14 {TclpRenameFile: errno: EACCES} -setup {
- cleanup
-} -constraints {win nt winOlderThan2000 testfile} -body {
- testfile mv nul tf1
-} -returnCodes error -result EACCES
test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} -setup {
cleanup
-} -constraints {win nt testfile} -body {
+} -constraints {win testfile} -body {
createfile tf1
testfile mv tf1 nul
} -returnCodes error -result EEXIST
@@ -238,19 +228,12 @@ test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} -setup {
} -returnCodes error -result ENOENT
test winFCmd-1.19 {TclpRenameFile: errno == EACCES} -setup {
cleanup
-} -constraints {win win2000orXP testfile} -body {
+} -constraints {win winXP testfile} -body {
testfile mv nul tf1
} -returnCodes error -result EINVAL
-test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} -setup {
- cleanup
-} -constraints {win nt winOlderThan2000 testfile} -body {
- testfile mv nul tf1
-} -returnCodes error -result EACCES
test winFCmd-1.20 {TclpRenameFile: src is dir} -setup {
cleanup
-} -constraints {win nt testfile} -body {
- # under 95, this would actually succeed and move the current dir out from
- # under the current process!
+} -constraints {win testfile} -body {
file delete /tf1
testfile mv [pwd] /tf1
} -returnCodes error -result EACCES
@@ -458,14 +441,9 @@ test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} -setup {
} -returnCodes error -result ENOENT
test winFCmd-2.7 {TclpCopyFile: errno: EACCES} -setup {
cleanup
-} -constraints {win win2000orXP testfile} -body {
+} -constraints {win winXP testfile} -body {
testfile cp nul tf1
} -returnCodes error -result EINVAL
-test winFCmd-2.8 {TclpCopyFile: errno: EACCES} -setup {
- cleanup
-} -constraints {win nt winOlderThan2000 testfile} -body {
- testfile cp nul tf1
-} -returnCodes error -result EACCES
test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} -setup {
cleanup
} -constraints {win testfile} -body {
@@ -623,7 +601,7 @@ test winFCmd-3.11 {TclpDeleteFile: still can't remove path} -setup {
test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} -body {
testfile mkdir $cdrom/dummy~~.dir
-} -constraints {win nt cdrom testfile} -returnCodes error -result EACCES
+} -constraints {win cdrom testfile} -returnCodes error -result EACCES
test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} -setup {
cleanup
} -constraints {win testfile} -body {
@@ -721,7 +699,7 @@ test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup {
} -result {td1 EACCES}
test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup {
cleanup
-} -constraints {win nt testfile} -body {
+} -constraints {win testfile} -body {
testfile rmdir /
# WinXP returns EEXIST, WinNT seems to return EACCES. No policy
# decision has been made as to which is correct.
@@ -819,7 +797,7 @@ test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} -setup {
} -result {tf1}
test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} -body {
testfile rmdir $cdrom/
-} -constraints {win nt cdrom testfile} -returnCodes error -match glob \
+} -constraints {win cdrom testfile} -returnCodes error -match glob \
-result {* EACCES}
test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} \
{win emptyTest} {
@@ -857,7 +835,7 @@ test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} -setup {
} -result {tf1}
test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} -setup {
cleanup
-} -constraints {win nt testfile} -body {
+} -constraints {win testfile} -body {
file mkdir td1
testfile cpdir td1 /
} -cleanup {
@@ -1072,7 +1050,7 @@ test winFCmd-12.5 {ConvertFileNameFormat: absolute path} -body {
} -constraints {win} -result {/ /}
test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} -setup {
catch {file delete -force -- c:/td1}
-} -constraints {win win2000orXP} -body {
+} -constraints {win winXP} -body {
createfile c:/td1 {}
string tolower [file attributes c:/td1 -longname]
} -cleanup {
@@ -1350,13 +1328,13 @@ test winFCmd-18.8 {Windows reserved path names} -constraints win -body {
file normalize cOm1:
} -result COM1
-test winFCmd-19.1 {Windows extended path names} -constraints nt -body {
+test winFCmd-19.1 {Windows extended path names} -constraints win -body {
file normalize //?/c:/windows/win.ini
} -result //?/c:/windows/win.ini
-test winFCmd-19.2 {Windows extended path names} -constraints nt -body {
+test winFCmd-19.2 {Windows extended path names} -constraints win -body {
file normalize //?/c:/windows/../windows/win.ini
} -result //?/c:/windows/win.ini
-test winFCmd-19.3 {Windows extended path names} -constraints nt -setup {
+test winFCmd-19.3 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp]
set tmpfile [file normalize $tmpfile]
} -body {
@@ -1367,7 +1345,7 @@ test winFCmd-19.3 {Windows extended path names} -constraints nt -setup {
} -cleanup {
catch {file delete $tmpfile}
} -result [list 0 {}]
-test winFCmd-19.4 {Windows extended path names} -constraints nt -setup {
+test winFCmd-19.4 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp]
set tmpfile //?/[file normalize $tmpfile]
} -body {
@@ -1378,7 +1356,7 @@ test winFCmd-19.4 {Windows extended path names} -constraints nt -setup {
} -cleanup {
catch {file delete $tmpfile}
} -result [list 0 {}]
-test winFCmd-19.5 {Windows extended path names} -constraints nt -setup {
+test winFCmd-19.5 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp]
set tmpfile [file normalize $tmpfile]
} -body {
@@ -1389,7 +1367,7 @@ test winFCmd-19.5 {Windows extended path names} -constraints nt -setup {
} -cleanup {
catch {file delete $tmpfile}
} -result [list 0 {}]
-test winFCmd-19.6 {Windows extended path names} -constraints nt -setup {
+test winFCmd-19.6 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp]
set tmpfile //?/[file normalize $tmpfile]
} -body {
@@ -1400,7 +1378,7 @@ test winFCmd-19.6 {Windows extended path names} -constraints nt -setup {
} -cleanup {
catch {file delete $tmpfile}
} -result [list 0 {}]
-test winFCmd-19.7 {Windows extended path names} -constraints nt -setup {
+test winFCmd-19.7 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) "tcl[pid].tmp "]
set tmpfile [file normalize $tmpfile]
} -body {
@@ -1411,7 +1389,7 @@ test winFCmd-19.7 {Windows extended path names} -constraints nt -setup {
} -cleanup {
catch {file delete $tmpfile}
} -result [list 0 {} [list tcl[pid].tmp]]
-test winFCmd-19.8 {Windows extended path names} -constraints nt -setup {
+test winFCmd-19.8 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) "tcl[pid].tmp "]
set tmpfile //?/[file normalize $tmpfile]
} -body {
@@ -1423,7 +1401,7 @@ test winFCmd-19.8 {Windows extended path names} -constraints nt -setup {
catch {file delete $tmpfile}
} -result [list 0 {} [list "tcl[pid].tmp "]]
-test winFCmd-19.9 {Windows devices path names} -constraints nt -body {
+test winFCmd-19.9 {Windows devices path names} -constraints win -body {
file normalize //./com1
} -result //./com1
diff --git a/tests/winFile.test b/tests/winFile.test
index 2c47f5f..b2cdfa1 100644
--- a/tests/winFile.test
+++ b/tests/winFile.test
@@ -21,23 +21,19 @@ catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint notNTFS 0
-testConstraint win2000 0
if {[testConstraint testvolumetype]} {
testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}]
}
-if {[testConstraint nt] && $::tcl_platform(osVersion) >= 5.0} {
- testConstraint win2000 1
-}
test winFile-1.1 {TclpGetUserHome} -constraints {win} -body {
glob ~nosuchuser
} -returnCodes error -result {user "nosuchuser" doesn't exist}
-test winFile-1.2 {TclpGetUserHome} -constraints {win nt nonPortable} -body {
+test winFile-1.2 {TclpGetUserHome} -constraints {win nonPortable} -body {
# The administrator account should always exist.
glob ~administrator
} -match glob -result *
-test winFile-1.4 {TclpGetUserHome} {win nt nonPortable} {
+test winFile-1.4 {TclpGetUserHome} {win nonPortable} {
catch {glob ~stanton@workgroup}
} {0}
@@ -154,7 +150,7 @@ if {[testConstraint win]} {
test winFile-4.0 {
Enhanced NTFS user/group permissions: test no acccess
} -constraints {
- win nt notNTFS win2000
+ win notNTFS
} -setup {
set owner [getuser $fname]
set user $::env(USERDOMAIN)\\$::env(USERNAME)
@@ -169,7 +165,7 @@ test winFile-4.0 {
test winFile-4.1 {
Enhanced NTFS user/group permissions: test readable only
} -constraints {
- win nt notNTFS
+ win notNTFS
} -setup {
set user $::env(USERDOMAIN)\\$::env(USERNAME)
} -body {
@@ -180,7 +176,7 @@ test winFile-4.1 {
test winFile-4.2 {
Enhanced NTFS user/group permissions: test writable only
} -constraints {
- win nt notNTFS
+ win notNTFS
} -setup {
set user $::env(USERDOMAIN)\\$::env(USERNAME)
} -body {
@@ -192,7 +188,7 @@ test winFile-4.2 {
test winFile-4.3 {
Enhanced NTFS user/group permissions: test read+write
} -constraints {
- win nt notNTFS
+ win notNTFS
} -setup {
set user $::env(USERDOMAIN)\\$::env(USERNAME)
} -body {
@@ -205,7 +201,7 @@ test winFile-4.3 {
test winFile-4.4 {
Enhanced NTFS user/group permissions: test full access
} -constraints {
- win nt notNTFS
+ win notNTFS
} -setup {
set user $::env(USERDOMAIN)\\$::env(USERNAME)
} -body {
diff --git a/tests/winPipe.test b/tests/winPipe.test
index 8128fe2..53e46fc 100644
--- a/tests/winPipe.test
+++ b/tests/winPipe.test
@@ -74,11 +74,11 @@ test winpipe-1.2 {32 bit comprehensive tests: from big file} {win exec cat32} {
exec $cat32 < $path(big) > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
-test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {win nt exec cat32} {
+test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {win exec cat32} {
exec [interpreter] $path(more) < $path(little) | $cat32 > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
-test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win nt exec cat32} {
+test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win exec cat32} {
exec [interpreter] $path(more) < $path(big) | $cat32 > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
@@ -171,7 +171,7 @@ test winpipe-1.21 {32 bit comprehensive tests: read/write application} \
set r
} "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
-test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} {
+test winpipe-4.1 {Tcl_WaitPid} {win exec cat32} {
proc readResults {f} {
global x result
if { [eof $f] } {
diff --git a/tests/zlib.test b/tests/zlib.test
index 15dbb34..ae8742b 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -138,6 +138,25 @@ test zlib-7.7 {zlib stream: Bug 25842c161} -constraints zlib -body {
} -cleanup {
catch {$s close}
} -result ""
+# Also causes Tk Bug 10f2e7872b
+test zlib-7.8 {zlib stream: Bug b26e38a3e4} -constraints zlib -setup {
+ expr srand(12345)
+ set randdata {}
+ for {set i 0} {$i<6001} {incr i} {
+ append randdata [binary format c [expr {int(256*rand())}]]
+ }
+} -body {
+ set strm [zlib stream compress]
+ for {set i 1} {$i<3000} {incr i} {
+ $strm put $randdata
+ }
+ $strm put -finalize $randdata
+ set data [$strm get]
+ list [string length $data] [string length [zlib decompress $data]]
+} -cleanup {
+ catch {$strm close}
+ unset -nocomplain randdata data
+} -result {120185 18003000}
test zlib-8.1 {zlib transformation} -constraints zlib -setup {
set file [makeFile {} test.gz]
generated by cgit v0.12 at 2025-06-02 12:06:10 (GMT)