summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authorKevin B Kenny <kennykb@acm.org>2014-06-29 02:20:31 (GMT)
committerKevin B Kenny <kennykb@acm.org>2014-06-29 02:20:31 (GMT)
commit54aa5c1f2d5513d45d1361a3615125a4810cc1c0 (patch)
tree9e84f6c42d0fdc3d3a0958996705d2c2fbb5f722 /tests
parent2ac3c16d405d20153ce0ad43f308ff05bc372f7a (diff)
parentc0edc29d67c0944180ce922c7f63d6dd3c3bdf6c (diff)
downloadtcl-54aa5c1f2d5513d45d1361a3615125a4810cc1c0.zip
tcl-54aa5c1f2d5513d45d1361a3615125a4810cc1c0.tar.gz
tcl-54aa5c1f2d5513d45d1361a3615125a4810cc1c0.tar.bz2
merge trunk
Diffstat (limited to 'tests')
-rw-r--r--tests/chanio.test6
-rw-r--r--tests/clock.test21
-rw-r--r--tests/cmdAH.test3
-rw-r--r--tests/dict.test131
-rw-r--r--tests/exec.test6
-rw-r--r--tests/fCmd.test10
-rw-r--r--tests/http.test12
-rw-r--r--tests/io.test393
-rw-r--r--tests/ioCmd.test112
-rw-r--r--tests/ioTrans.test53
-rw-r--r--tests/iogt.test109
-rw-r--r--tests/namespace.test6
-rw-r--r--tests/obj.test4
-rw-r--r--tests/regexp.test16
-rw-r--r--tests/regexpComp.test16
-rw-r--r--tests/socket.test601
-rw-r--r--tests/string.test13
-rw-r--r--tests/stringComp.test34
-rw-r--r--tests/subst.test8
-rw-r--r--tests/switch.test8
-rw-r--r--tests/winFCmd.test100
-rw-r--r--tests/winFile.test18
-rw-r--r--tests/winPipe.test8
-rw-r--r--tests/zlib.test2
24 files changed, 1377 insertions, 313 deletions
diff --git a/tests/chanio.test b/tests/chanio.test
index 999d0bb..e53f059 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -44,7 +44,7 @@ namespace eval ::tcl::test::io {
# You need a *very* special environment to do some tests. In particular,
# many file systems do not support large-files...
- testConstraint largefileSupport 0
+ testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2 if "umask" cannot be run, the
# tests will be skipped.
@@ -4520,10 +4520,10 @@ test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} -setup {
chan puts -nonewline $f abcdef
lappend l [chan tell $f]
chan close $f
- lappend l [file size $f]
+ lappend l [file size $path(test3)]
# truncate...
chan close [open $path(test3) w]
- lappend l [file size $f]
+ lappend l [file size $path(test3)]
} -result {0 6 6 4294967296 4294967302 4294967302 0}
# Test Tcl_Eof
diff --git a/tests/clock.test b/tests/clock.test
index 0202fc7..2abeab9 100644
--- a/tests/clock.test
+++ b/tests/clock.test
@@ -273,7 +273,7 @@ test clock-1.4 "clock format - bad flag" {*}{
list [catch {clock format 0 -oops badflag} msg] $msg $::errorCode
}
-match glob
- -result {1 {bad switch "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badSwitch -oops}}
+ -result {1 {bad option "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badOption -oops}}
}
test clock-1.5 "clock format - bad timezone" {
@@ -35450,7 +35450,7 @@ test clock-33.2 {clock clicks tests} {
} {1}
test clock-33.3 {clock clicks tests} {
list [catch {clock clicks foo} msg] $msg
-} {1 {bad switch "foo": must be -milliseconds or -microseconds}}
+} {1 {bad option "foo": must be -milliseconds or -microseconds}}
test clock-33.4 {clock clicks tests} {
expr [clock clicks -milliseconds]+1
concat {}
@@ -35485,10 +35485,10 @@ test clock-33.5a {clock tests, millisecond timing test} {
} {ok}
test clock-33.6 {clock clicks, milli with too much abbreviation} {
list [catch { clock clicks ? } msg] $msg
-} {1 {bad switch "?": must be -milliseconds or -microseconds}}
+} {1 {bad option "?": must be -milliseconds or -microseconds}}
test clock-33.7 {clock clicks, milli with too much abbreviation} {
list [catch { clock clicks - } msg] $msg
-} {1 {ambiguous switch "-": must be -milliseconds or -microseconds}}
+} {1 {ambiguous option "-": must be -milliseconds or -microseconds}}
test clock-33.8 {clock clicks test, microsecond timing test} {
# This test can fail on a system that is so heavily loaded that
@@ -35607,7 +35607,7 @@ test clock-34.8 {clock scan tests} {
} {Oct 23,1992 15:00 GMT}
test clock-34.9 {clock scan tests} {
list [catch {clock scan "Jan 12" -bad arg} msg] $msg
-} {1 {bad switch "-bad", must be -base, -format, -gmt, -locale or -timezone}}
+} {1 {bad option "-bad", must be -base, -format, -gmt, -locale or -timezone}}
# The following two two tests test the two year date policy
test clock-34.10 {clock scan tests} {
set time [clock scan "1/1/71" -gmt true]
@@ -36907,7 +36907,7 @@ test clock-65.1 {clock add, bad option [Bug 2481670]} {*}{
}
-match glob
-returnCodes error
- -result {bad switch "-foo"*}
+ -result {bad option "-foo"*}
}
test clock-66.1 {clock scan, no date, never-before-seen timezone} {*}{
@@ -36927,6 +36927,15 @@ test clock-67.1 {clock format, %% with a letter following [Bug 2819334]} {
clock format [clock seconds] -format %%r
} %r
+test clock-67.2 {Bug d19a30db57} -body {
+ # error, not segfault
+ tcl::clock::GetJulianDayFromEraYearMonthDay {} 2361222
+} -returnCodes error -match glob -result *
+test clock-67.3 {Bug d19a30db57} -body {
+ # error, not segfault
+ tcl::clock::GetJulianDayFromEraYearWeekDay {} 2361222
+} -returnCodes error -match glob -result *
+
# cleanup
namespace delete ::testClock
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index 39e9ece..04a86fa 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -141,6 +141,9 @@ test cmdAH-2.6.2 {cd} -constraints {unix nonPortable} -setup {
} -cleanup {
cd $dir
} -result {/}
+test cmdAH-2.6.3 {Tcl_CdObjCmd, bug #3118489} -returnCodes error -body {
+ cd .\0
+} -result "couldn't change working directory to \".\0\": no such file or directory"
test cmdAH-2.7 {Tcl_ConcatObjCmd} {
concat
} {}
diff --git a/tests/dict.test b/tests/dict.test
index a583de8..d5406d0 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -167,6 +167,51 @@ test dict-4.8 {dict replace command} -returnCodes error -body {
} -result {missing value to go with key}
test dict-4.9 {dict replace command} {dict replace [list a a] a b} {a b}
test dict-4.10 {dict replace command} {dict replace [list a a] a b a c} {a c}
+test dict-4.11 {dict replace command: canonicality is forced} {
+ dict replace { a b c d }
+} {a b c d}
+test dict-4.12 {dict replace command: canonicality is forced} {
+ dict replace {a b c d a e}
+} {a e c d}
+test dict-4.13 {dict replace command: type check is mandatory} -body {
+ dict replace { a b c d e }
+} -returnCodes error -result {missing value to go with key}
+test dict-4.13a {dict replace command: type check is mandatory} {
+ catch {dict replace { a b c d e }} -> opt
+ dict get $opt -errorcode
+} {TCL VALUE DICTIONARY}
+test dict-4.14 {dict replace command: type check is mandatory} -body {
+ dict replace { a b {}c d }
+} -returnCodes error -result {dict element in braces followed by "c" instead of space}
+test dict-4.14a {dict replace command: type check is mandatory} {
+ catch {dict replace { a b {}c d }} -> opt
+ dict get $opt -errorcode
+} {TCL VALUE DICTIONARY JUNK}
+test dict-4.15 {dict replace command: type check is mandatory} -body {
+ dict replace { a b ""c d }
+} -returnCodes error -result {dict element in quotes followed by "c" instead of space}
+test dict-4.15a {dict replace command: type check is mandatory} {
+ catch {dict replace { a b ""c d }} -> opt
+ dict get $opt -errorcode
+} {TCL VALUE DICTIONARY JUNK}
+test dict-4.16 {dict replace command: type check is mandatory} -body {
+ dict replace " a b \"c d "
+} -returnCodes error -result {unmatched open quote in dict}
+test dict-4.16a {dict replace command: type check is mandatory} {
+ catch {dict replace " a b \"c d "} -> opt
+ dict get $opt -errorcode
+} {TCL VALUE DICTIONARY QUOTE}
+test dict-4.17 {dict replace command: type check is mandatory} -body {
+ dict replace " a b \{c d "
+} -returnCodes error -result {unmatched open brace in dict}
+test dict-4.17a {dict replace command: type check is mandatory} {
+ catch {dict replace " a b \{c d "} -> opt
+ dict get $opt -errorcode
+} {TCL VALUE DICTIONARY BRACE}
+test dict-4.18 {dict replace command: canonicality forcing doesn't leak} {
+ set example { a b c d }
+ list $example [dict replace $example]
+} {{ a b c d } {a b c d}}
test dict-5.1 {dict remove command} {dict remove {a b c d} a} {c d}
test dict-5.2 {dict remove command} {dict remove {a b c d} c} {a b}
@@ -179,6 +224,25 @@ test dict-5.6 {dict remove command} {dict remove {a b} c} {a b}
test dict-5.7 {dict remove command} -returnCodes error -body {
dict remove
} -result {wrong # args: should be "dict remove dictionary ?key ...?"}
+test dict-5.8 {dict remove command: canonicality is forced} {
+ dict remove { a b c d }
+} {a b c d}
+test dict-5.9 {dict remove command: canonicality is forced} {
+ dict remove {a b c d a e}
+} {a e c d}
+test dict-5.10 {dict remove command: canonicality forced by update} {
+ dict remove { a b c d } c
+} {a b}
+test dict-5.11 {dict remove command: type check is mandatory} -body {
+ dict remove { a b c d e }
+} -returnCodes error -result {missing value to go with key}
+test dict-5.12 {dict remove command: type check is mandatory} -body {
+ dict remove { a b {}c d }
+} -returnCodes error -result {dict element in braces followed by "c" instead of space}
+test dict-5.13 {dict remove command: canonicality forcing doesn't leak} {
+ set example { a b c d }
+ list $example [dict remove $example]
+} {{ a b c d } {a b c d}}
test dict-6.1 {dict keys command} {dict keys {a b}} a
test dict-6.2 {dict keys command} {dict keys {c d}} c
@@ -345,13 +409,13 @@ test dict-11.13 {dict incr command} -returnCodes error -body {
dict incr dictv a a a
} -cleanup {
unset dictv
-} -result {wrong # args: should be "dict incr varName key ?increment?"}
+} -result {wrong # args: should be "dict incr dictVarName key ?increment?"}
test dict-11.14 {dict incr command} -returnCodes error -body {
set dictv a
dict incr dictv
} -cleanup {
unset dictv
-} -result {wrong # args: should be "dict incr varName key ?increment?"}
+} -result {wrong # args: should be "dict incr dictVarName key ?increment?"}
test dict-11.15 {dict incr command: write failure} -setup {
unset -nocomplain dictVar
} -body {
@@ -422,10 +486,10 @@ test dict-12.6 {dict lappend command} -returnCodes error -body {
} -result {missing value to go with key}
test dict-12.7 {dict lappend command} -returnCodes error -body {
dict lappend
-} -result {wrong # args: should be "dict lappend varName key ?value ...?"}
+} -result {wrong # args: should be "dict lappend dictVarName key ?value ...?"}
test dict-12.8 {dict lappend command} -returnCodes error -body {
dict lappend dictv
-} -result {wrong # args: should be "dict lappend varName key ?value ...?"}
+} -result {wrong # args: should be "dict lappend dictVarName key ?value ...?"}
test dict-12.9 {dict lappend command} -returnCodes error -body {
set dictv [dict create a "\{"]
dict lappend dictv a a
@@ -489,10 +553,10 @@ test dict-13.6 {dict append command} -returnCodes error -body {
} -result {missing value to go with key}
test dict-13.7 {dict append command} -returnCodes error -body {
dict append
-} -result {wrong # args: should be "dict append varName key ?value ...?"}
+} -result {wrong # args: should be "dict append dictVarName key ?value ...?"}
test dict-13.8 {dict append command} -returnCodes error -body {
dict append dictv
-} -result {wrong # args: should be "dict append varName key ?value ...?"}
+} -result {wrong # args: should be "dict append dictVarName key ?value ...?"}
test dict-13.9 {dict append command: write failure} -setup {
unset -nocomplain dictVar
} -body {
@@ -510,16 +574,16 @@ test dict-13.11 {compiled dict append: invalidate string rep - Bug 3079830} {
test dict-14.1 {dict for command: syntax} -returnCodes error -body {
dict for
-} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"}
+} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"}
test dict-14.2 {dict for command: syntax} -returnCodes error -body {
dict for x
-} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"}
+} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"}
test dict-14.3 {dict for command: syntax} -returnCodes error -body {
dict for x x
-} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"}
+} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"}
test dict-14.4 {dict for command: syntax} -returnCodes error -body {
dict for x x x x
-} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"}
+} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"}
test dict-14.5 {dict for command: syntax} -returnCodes error -body {
dict for x x x
} -result {must have exactly two variable names}
@@ -749,13 +813,13 @@ test dict-15.9 {dict set command: write failure} -setup {
} -result {can't set "dictVar": variable is array}
test dict-15.10 {dict set command: syntax} -returnCodes error -body {
dict set
-} -result {wrong # args: should be "dict set varName key ?key ...? value"}
+} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"}
test dict-15.11 {dict set command: syntax} -returnCodes error -body {
dict set a
-} -result {wrong # args: should be "dict set varName key ?key ...? value"}
+} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"}
test dict-15.12 {dict set command: syntax} -returnCodes error -body {
dict set a a
-} -result {wrong # args: should be "dict set varName key ?key ...? value"}
+} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"}
test dict-15.13 {dict set command} -returnCodes error -body {
set dictVar a
dict set dictVar b c
@@ -808,7 +872,7 @@ test dict-16.7 {dict unset command} -setup {
} -result {0 {} 1}
test dict-16.8 {dict unset command} -returnCodes error -body {
dict unset dictVar
-} -result {wrong # args: should be "dict unset varName key ?key ...?"}
+} -result {wrong # args: should be "dict unset dictVarName key ?key ...?"}
test dict-16.9 {dict unset command: write failure} -setup {
unset -nocomplain dictVar
} -body {
@@ -859,7 +923,7 @@ test dict-16.16 {dict unset command} -body {
} -result {0 {} 1}
test dict-16.17 {dict unset command} -returnCodes error -body {
apply {{} {dict unset dictVar}}
-} -result {wrong # args: should be "dict unset varName key ?key ...?"}
+} -result {wrong # args: should be "dict unset dictVarName key ?key ...?"}
test dict-16.18 {dict unset command: write failure} -body {
apply {{} {
set dictVar(block) {}
@@ -988,7 +1052,7 @@ test dict-17.17 {dict filter command: script} -body {
} -result b
test dict-17.18 {dict filter command: script} -returnCodes error -body {
dict filter {a b} script {k k}
-} -result {wrong # args: should be "dict filter dictionary script {keyVar valueVar} filterScript"}
+} -result {wrong # args: should be "dict filter dictionary script {keyVarName valueVarName} filterScript"}
test dict-17.19 {dict filter command: script} -returnCodes error -body {
dict filter {a b} script k {continue}
} -result {must have exactly two variable names}
@@ -1226,19 +1290,34 @@ test dict-20.19 {dict merge command} {
test dict-20.20 {dict merge command} {
apply {{} {dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}}}
} {a - c d e f 1 - 3 4}
+test dict-20.21 {dict merge command: canonicality not forced} {
+ dict merge { a b c d }
+} { a b c d }
+test dict-20.22 {dict merge command: canonicality not forced} {
+ dict merge { a b c d } {}
+} { a b c d }
+test dict-20.23 {dict merge command: canonicality forced by update} {
+ dict merge { a b c d } {a b}
+} {a b c d}
+test dict-20.24 {dict merge command: type check is mandatory} -body {
+ dict merge { a b c d e }
+} -returnCodes error -result {missing value to go with key}
+test dict-20.25 {dict merge command: type check is mandatory} -body {
+ dict merge { a b {}c d }
+} -returnCodes error -result {dict element in braces followed by "c" instead of space}
test dict-21.1 {dict update command} -returnCodes 1 -body {
dict update
-} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
+} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"}
test dict-21.2 {dict update command} -returnCodes 1 -body {
dict update v
-} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
+} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"}
test dict-21.3 {dict update command} -returnCodes 1 -body {
dict update v k
-} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
+} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"}
test dict-21.4 {dict update command} -returnCodes 1 -body {
dict update v k v
-} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
+} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"}
test dict-21.5 {dict update command} -body {
set a {b c}
set result {}
@@ -1376,10 +1455,10 @@ test dict-21.17 {dict update command: no recursive structures [Bug 1786481]} {
test dict-22.1 {dict with command} -body {
dict with
-} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"}
+} -returnCodes 1 -result {wrong # args: should be "dict with dictVarName ?key ...? script"}
test dict-22.2 {dict with command} -body {
dict with v
-} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"}
+} -returnCodes 1 -result {wrong # args: should be "dict with dictVarName ?key ...? script"}
test dict-22.3 {dict with command} -body {
unset -nocomplain v
dict with v {error "in body"}
@@ -1639,16 +1718,16 @@ rename linenumber {}
test dict-24.1 {dict map command: syntax} -returnCodes error -body {
dict map
-} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
+} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"}
test dict-24.2 {dict map command: syntax} -returnCodes error -body {
dict map x
-} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
+} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"}
test dict-24.3 {dict map command: syntax} -returnCodes error -body {
dict map x x
-} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
+} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"}
test dict-24.4 {dict map command: syntax} -returnCodes error -body {
dict map x x x x
-} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
+} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"}
test dict-24.5 {dict map command: syntax} -returnCodes error -body {
dict map x x x
} -result {must have exactly two variable names}
diff --git a/tests/exec.test b/tests/exec.test
index 871c0c5..16a8320 100644
--- a/tests/exec.test
+++ b/tests/exec.test
@@ -370,7 +370,7 @@ err}
test exec-10.1 {errors in exec invocation} -constraints {exec} -body {
exec
-} -returnCodes error -result {wrong # args: should be "exec ?-switch ...? arg ?arg ...?"}
+} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"}
test exec-10.2 {errors in exec invocation} -constraints {exec} -body {
exec | cat
} -returnCodes error -result {illegal use of | or |& in command}
@@ -545,10 +545,10 @@ test exec-14.1 {-keepnewline switch} {exec} {
} "foo\n"
test exec-14.2 {-keepnewline switch} -constraints {exec} -body {
exec -keepnewline
-} -returnCodes error -result {wrong # args: should be "exec ?-switch ...? arg ?arg ...?"}
+} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"}
test exec-14.3 {unknown switch} -constraints {exec} -body {
exec -gorp
-} -returnCodes error -result {bad switch "-gorp": must be -ignorestderr, -keepnewline, or --}
+} -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, or --}
test exec-14.4 {-- switch} -constraints {exec} -body {
exec -- -gorp
} -returnCodes error -result {couldn't execute "-gorp": no such file or directory}
diff --git a/tests/fCmd.test b/tests/fCmd.test
index 8f27ad4..5836e00 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -511,12 +511,6 @@ test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} -setup {
} -returnCodes error -cleanup {
testchmod 755 td1
} -result {error renaming "tf1" to "td1/tf1": permission denied}
-test fCmd-6.7 {CopyRenameOneFile: errno != ENOENT} -setup {
- cleanup
-} -constraints {win 95} -returnCodes error -body {
- createfile tf1
- file rename tf1 $long
-} -result [subst {error renaming "tf1" to "$long": file name too long}]
test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} -setup {
cleanup
} -constraints {unix notRoot} -body {
@@ -2330,10 +2324,10 @@ test fCmd-28.2 {file link} -returnCodes error -body {
} -result {wrong # args: should be "file link ?-linktype? linkname ?target?"}
test fCmd-28.3 {file link} -returnCodes error -body {
file link abc b c
-} -result {bad switch "abc": must be -symbolic or -hard}
+} -result {bad option "abc": must be -symbolic or -hard}
test fCmd-28.4 {file link} -returnCodes error -body {
file link -abc b c
-} -result {bad switch "-abc": must be -symbolic or -hard}
+} -result {bad option "-abc": must be -symbolic or -hard}
cd [workingDirectory]
makeDirectory abc.dir
makeDirectory abc2.dir
diff --git a/tests/http.test b/tests/http.test
index a52cfb1..a0a26de 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -492,14 +492,10 @@ proc myProgress {token total current} {
}
set progress [list $total $current]
}
-if 0 {
- # This test hangs on Windows95 because the client never gets EOF
- set httpLog 1
- test http-4.6.1 {http::Event} knownBug {
- set token [http::geturl $url -blocksize 50 -progress myProgress]
- return $progress
- } {111 111}
-}
+test http-4.6.1 {http::Event} knownBug {
+ set token [http::geturl $url -blocksize 50 -progress myProgress]
+ return $progress
+} {111 111}
test http-4.7 {http::Event} -body {
set token [http::geturl $url -keepalive 0 -progress myProgress]
return $progress
diff --git a/tests/io.test b/tests/io.test
index 0688c14..cf38a1b 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -45,7 +45,7 @@ testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
-testConstraint largefileSupport 0
+testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
@@ -1449,6 +1449,39 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe filee
lappend x [catch {close $f} msg] $msg
set x
} "{} timeout {} timeout \u7266 {} eof 0 {}"
+test io-12.6 {ReadChars: too many chars read} {
+ proc driver {cmd args} {
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) [encoding convertto utf-8 \
+ [string repeat \uBEEF 20][string repeat . 20]]
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan)
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
+ }
+ set c [chan create read [namespace which driver]]
+ chan configure $c -encoding utf-8
+ while {![eof $c]} {
+ read $c 15
+ }
+ close $c
+} {}
test io-13.1 {TranslateInputEOL: cr mode} {} {
set f [open $path(test1) w]
@@ -1563,6 +1596,45 @@ test io-13.8 {TranslateInputEOL: auto mode: \r\n} {
close $f
set x
} "abcd\ndef"
+test io-13.8.1 {TranslateInputEOL: auto mode: \r\n} {
+ set f [open $path(test1) w]
+ fconfigure $f -translation lf
+ puts -nonewline $f "abcd\r\ndef"
+ close $f
+ set f [open $path(test1)]
+ fconfigure $f -translation auto
+ set x {}
+ lappend x [read $f 5]
+ lappend x [read $f]
+ close $f
+ set x
+} [list "abcd\n" "def"]
+test io-13.8.2 {TranslateInputEOL: auto mode: \r\n} {
+ set f [open $path(test1) w]
+ fconfigure $f -translation lf
+ puts -nonewline $f "abcd\r\ndef"
+ close $f
+ set f [open $path(test1)]
+ fconfigure $f -translation auto -buffersize 6
+ set x {}
+ lappend x [read $f 5]
+ lappend x [read $f]
+ close $f
+ set x
+} [list "abcd\n" "def"]
+test io-13.8.3 {TranslateInputEOL: auto mode: \r\n} {
+ set f [open $path(test1) w]
+ fconfigure $f -translation lf
+ puts -nonewline $f "abcd\r\n\r\ndef"
+ close $f
+ set f [open $path(test1)]
+ fconfigure $f -translation auto -buffersize 7
+ set x {}
+ lappend x [read $f 5]
+ lappend x [read $f]
+ close $f
+ set x
+} [list "abcd\n" "\ndef"]
test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
@@ -2771,7 +2843,7 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa
variable x running
set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
proc writelots {s l} {
- for {set i 0} {$i < 2000} {incr i} {
+ for {set i 0} {$i < 9000} {incr i} {
puts $s $l
}
}
@@ -2802,7 +2874,7 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa
close $ss
vwait [namespace which -variable x]
set c
-} 2000
+} 9000
test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac fileevent} {
# On Mac, this test screws up sockets such that subsequent tests using port 2828
# either cause errors or panic().
@@ -3984,6 +4056,46 @@ test io-32.11 {Tcl_Read from a pipe} {stdio openpipe} {
} {{hello
} {hello
}}
+test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} {
+ file delete $path(pipe)
+ set f1 [open $path(pipe) w]
+ puts $f1 {chan configure stdout -translation crlf}
+ puts $f1 {puts [gets stdin]}
+ puts $f1 {puts [gets stdin]}
+ close $f1
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
+ puts $f1 hello
+ flush $f1
+ set x ""
+ lappend x [read $f1 6]
+ puts $f1 hello
+ flush $f1
+ lappend x [read $f1]
+ close $f1
+ set x
+} {{hello
+} {hello
+}}
+test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} {
+ file delete $path(pipe)
+ set f1 [open $path(pipe) w]
+ puts $f1 {chan configure stdout -translation crlf}
+ puts $f1 {puts [gets stdin]}
+ puts $f1 {puts [gets stdin]}
+ close $f1
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
+ puts $f1 hello
+ flush $f1
+ set x ""
+ lappend x [read $f1 6]
+ puts $f1 hello
+ flush $f1
+ lappend x [read $f1]
+ close $f1
+ set x
+} {{hello
+} {hello
+}}
test io-32.12 {Tcl_Read, -nonewline} {
file delete $path(test1)
set f1 [open $path(test1) w]
@@ -4457,10 +4569,10 @@ test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} {
puts -nonewline $f abcdef
lappend l [tell $f]
close $f
- lappend l [file size $f]
+ lappend l [file size $path(test3)]
# truncate...
close [open $path(test3) w]
- lappend l [file size $f]
+ lappend l [file size $path(test3)]
set l
} {0 6 6 4294967296 4294967302 4294967302 0}
@@ -4725,6 +4837,92 @@ test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} {
close $f
list $c $l $e
} {21 8 1}
+test io-35.18 {Tcl_Eof, eof char, cr write, crlf read} -body {
+ file delete $path(test1)
+ set f [open $path(test1) w]
+ fconfigure $f -translation cr
+ puts $f abc\ndef
+ close $f
+ set s [file size $path(test1)]
+ set f [open $path(test1) r]
+ fconfigure $f -translation crlf
+ set l [string length [set in [read $f]]]
+ set e [eof $f]
+ close $f
+ list $s $l $e [scan [string index $in end] %c]
+} -result {8 8 1 13}
+test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body {
+ file delete $path(test1)
+ set f [open $path(test1) w]
+ fconfigure $f -translation cr -eofchar \x1a
+ puts $f abc\ndef
+ close $f
+ set s [file size $path(test1)]
+ set f [open $path(test1) r]
+ fconfigure $f -translation crlf -eofchar \x1a
+ set l [string length [set in [read $f]]]
+ set e [eof $f]
+ close $f
+ list $s $l $e [scan [string index $in end] %c]
+} -result {9 8 1 13}
+test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} -body {
+ file delete $path(test1)
+ set f [open $path(test1) w]
+ fconfigure $f -translation cr -eofchar \x1a
+ puts $f {}
+ close $f
+ set s [file size $path(test1)]
+ set f [open $path(test1) r]
+ fconfigure $f -translation crlf -eofchar \x1a
+ set l [string length [set in [read $f]]]
+ set e [eof $f]
+ close $f
+ list $s $l $e [scan [string index $in end] %c]
+} -result {2 1 1 13}
+test io-35.18c {Tcl_Eof, eof char, cr write, crlf read} -body {
+ file delete $path(test1)
+ set f [open $path(test1) w]
+ fconfigure $f -translation cr
+ puts $f {}
+ close $f
+ set s [file size $path(test1)]
+ set f [open $path(test1) r]
+ fconfigure $f -translation crlf
+ set l [string length [set in [read $f]]]
+ set e [eof $f]
+ close $f
+ list $s $l $e [scan [string index $in end] %c]
+} -result {1 1 1 13}
+test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} -body {
+ file delete $path(test1)
+ set f [open $path(test1) w]
+ fconfigure $f -translation cr -eofchar {}
+ set i [format abc\ndef\n%cqrs\nuvw 26]
+ puts $f $i
+ close $f
+ set c [file size $path(test1)]
+ set f [open $path(test1) r]
+ fconfigure $f -translation crlf -eofchar \x1a
+ set l [string length [set in [read $f]]]
+ set e [eof $f]
+ close $f
+ list $c $l $e [scan [string index $in end] %c]
+} -result {17 8 1 13}
+test io-35.20 {Tcl_Eof, eof char in middle, cr write, crlf read} {
+ file delete $path(test1)
+ set f [open $path(test1) w]
+ fconfigure $f -translation cr -eofchar {}
+ set i [format \n%cqrsuvw 26]
+ puts $f $i
+ close $f
+ set c [file size $path(test1)]
+ set f [open $path(test1) r]
+ fconfigure $f -translation crlf -eofchar \x1a
+ set l [string length [set in [read $f]]]
+ set e [eof $f]
+ close $f
+ list $c $l $e [scan [string index $in end] %c]
+} {9 1 1 13}
# Test Tcl_InputBlocked
@@ -6564,11 +6762,23 @@ test io-52.4 {TclCopyChannel} {fcopy} {
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
fcopy $f1 $f2 -size 40
- set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
+ set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
lappend result [file size $path(test1)]
-} {0 0 40}
+} {0 0 0 40}
+test io-52.4.1 {TclCopyChannel} {fcopy} {
+ file delete $path(test1)
+ set f1 [open $thisScript]
+ set f2 [open $path(test1) w]
+ fconfigure $f1 -translation lf -blocking 0 -buffersize 10000000
+ fconfigure $f2 -translation cr -blocking 0
+ fcopy $f1 $f2 -size 40
+ set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
+ close $f1
+ close $f2
+ lappend result [file size $path(test1)]
+} {0 0 0 40}
test io-52.5 {TclCopyChannel, all} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
@@ -6754,6 +6964,150 @@ test io-52.11 {TclCopyChannel & encodings} {fcopy} {
file size $path(kyrillic.txt)
} 3
+test io-52.12 {coverage of -translation auto} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -buffersize 8
+ set out [open $path(test2) w]
+ chan configure $out -translation lf
+ fcopy $in $out
+ close $in
+ close $out
+ file size $path(test2)
+} 29
+test io-52.13 {coverage of -translation cr} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -buffersize 8 -translation cr
+ set out [open $path(test2) w]
+ chan configure $out -translation lf
+ fcopy $in $out
+ close $in
+ close $out
+ file size $path(test2)
+} 30
+test io-52.14 {coverage of -translation crlf} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -buffersize 8 -translation crlf
+ set out [open $path(test2) w]
+ chan configure $out -translation lf
+ fcopy $in $out
+ close $in
+ close $out
+ file size $path(test2)
+} 29
+test io-52.14.1 {coverage of -translation crlf} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -buffersize 8 -translation crlf
+ set out [open $path(test2) w]
+ fcopy $in $out -size 2
+ close $in
+ close $out
+ file size $path(test2)
+} 2
+test io-52.14.2 {coverage of -translation crlf} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -translation crlf
+ set out [open $path(test2) w]
+ fcopy $in $out -size 9
+ close $in
+ close $out
+ file size $path(test2)
+} 9
+test io-52.15 {coverage of -translation crlf} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\r
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -buffersize 8 -translation crlf
+ set out [open $path(test2) w]
+ fcopy $in $out
+ close $in
+ close $out
+ file size $path(test2)
+} 8
+test io-52.16 {coverage of eofChar handling} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -buffersize 8 -translation lf -eofchar a
+ set out [open $path(test2) w]
+ fcopy $in $out
+ close $in
+ close $out
+ file size $path(test2)
+} 0
+test io-52.17 {coverage of eofChar handling} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -buffersize 8 -translation lf -eofchar d
+ set out [open $path(test2) w]
+ fcopy $in $out
+ close $in
+ close $out
+ file size $path(test2)
+} 3
+test io-52.18 {coverage of eofChar handling} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -buffersize 8 -translation crlf -eofchar h
+ set out [open $path(test2) w]
+ fcopy $in $out
+ close $in
+ close $out
+ file size $path(test2)
+} 8
+test io-52.19 {coverage of eofChar handling} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -buffersize 10 -translation crlf -eofchar h
+ set out [open $path(test2) w]
+ fcopy $in $out
+ close $in
+ close $out
+ file size $path(test2)
+} 8
+
test io-53.1 {CopyData} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
@@ -6823,17 +7177,12 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven
for {set x 0} {$x < 12} {incr x} {
append big $big
}
- file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
puts ready
fcopy stdin stdout -command { set x }
vwait x
- set f [open $path(test1) w]
- fconfigure $f -translation lf
- puts $f "done"
- close $f
}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
@@ -6841,7 +7190,6 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven
fconfigure $f1 -blocking 0
puts $f1 $big
flush $f1
- after 500
set result ""
fileevent $f1 read [namespace code {
append result [read $f1 1024]
@@ -7223,6 +7571,25 @@ test io-53.11 {Bug 2895565} -setup {
removeFile out
removeFile in
} -result {40 bytes copied}
+test io-53.12 {CopyData: foreground short reads, aka bug 3096275} {stdio unix openpipe fcopy} {
+ file delete $path(pipe)
+ set f1 [open $path(pipe) w]
+ puts -nonewline $f1 {
+ fconfigure stdin -translation binary -blocking 0
+ fconfigure stdout -buffering none -translation binary
+ fcopy stdin stdout
+ }
+ close $f1
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
+ fconfigure $f1 -translation binary -buffering none
+ puts -nonewline $f1 A
+ after 2000 {set ::done timeout}
+ fileevent $f1 readable {set ::done ok}
+ vwait ::done
+ set ch [read $f1 1]
+ close $f1
+ list $::done $ch
+} {ok A}
test io-54.1 {Recursive channel events} {socket fileevent} {
# This test checks to see if file events are delivered during recursive
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 03242be..8d35ec7 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -639,7 +639,7 @@ test iocmd-15.9 {Tcl_FcopyObjCmd} {fcopy} {
} "1 {channel \"$rfile\" wasn't opened for writing}"
test iocmd-15.10 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $rfile $wfile foo bar} msg] $msg
-} {1 {bad switch "foo": must be -size or -command}}
+} {1 {bad option "foo": must be -size or -command}}
test iocmd-15.11 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $rfile $wfile -size foo} msg] $msg
} {1 {expected integer but got "foo"}}
@@ -793,6 +793,90 @@ test iocmd-21.19 {chan create, init failure -> no channel, no finalize} -match g
rename foo {}
set res
} -result {{} {initialize rc* {read write}} 1 {*all required methods*} {}}
+test iocmd-21.20 {Bug 88aef05cda} -setup {
+ proc foo {method chan args} {
+ switch -- $method blocking {
+ chan configure $chan -blocking [lindex $args 0]
+ return
+ } initialize {
+ return {initialize finalize watch blocking read write
+ configure cget cgetall}
+ } finalize {
+ return
+ }
+ }
+ set ch [chan create {read write} foo]
+} -body {
+ list [catch {chan configure $ch -blocking 0} m] $m
+} -cleanup {
+ close $ch
+ rename foo {}
+} -match glob -result {1 {*nested eval*}}
+test iocmd-21.21 {[close] in [read] segfaults} -setup {
+ proc foo {method chan args} {
+ switch -- $method initialize {
+ return {initialize finalize watch read}
+ } finalize {} watch {} read {
+ close $chan
+ return a
+ }
+ }
+ set ch [chan create read foo]
+} -body {
+ read $ch 0
+} -cleanup {
+ close $ch
+ rename foo {}
+} -result {}
+test iocmd-21.22 {[close] in [read] segfaults} -setup {
+ proc foo {method chan args} {
+ switch -- $method initialize {
+ return {initialize finalize watch read}
+ } finalize {} watch {} read {
+ catch {close $chan}
+ return a
+ }
+ }
+ set ch [chan create read foo]
+} -body {
+ read $ch 1
+} -returnCodes error -cleanup {
+ catch {close $ch}
+ rename foo {}
+} -match glob -result {*invalid argument*}
+test iocmd-21.23 {[close] in [gets] segfaults} -setup {
+ proc foo {method chan args} {
+ switch -- $method initialize {
+ return {initialize finalize watch read}
+ } finalize {} watch {} read {
+ catch {close $chan}
+ return \n
+ }
+ }
+ set ch [chan create read foo]
+} -body {
+ gets $ch
+} -cleanup {
+ catch {close $ch}
+ rename foo {}
+} -result {}
+test iocmd-21.24 {[close] in binary [gets] segfaults} -setup {
+ proc foo {method chan args} {
+ switch -- $method initialize {
+ return {initialize finalize watch read}
+ } finalize {} watch {} read {
+ catch {close $chan}
+ return \n
+ }
+ }
+ set ch [chan create read foo]
+} -body {
+ chan configure $ch -translation binary
+ gets $ch
+} -cleanup {
+ catch {close $ch}
+ rename foo {}
+} -result {}
# --- --- --- --------- --------- ---------
# Helper commands to record the arguments to handler methods.
@@ -1051,6 +1135,20 @@ test iocmd-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glo
rename foo {}
unset res
} -result {{read rc* 4096} {} 0}
+test iocmd-23.11 {chan read, close pulls the rug out} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ set args [lassign $args sub id]
+ if {$sub ne "read"} {return}
+ close $id
+ return {}
+ }
+ set c [chan create {r} foo]
+ note [read $c]
+ rename foo {}
+ set res
+} -result {{read rc* 4096} {}}
# --- === *** ###########################
# method write
@@ -1978,13 +2076,13 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m
proc foo {args} {
oninit; onfinal; track;
# destroy interpreter during channel access
- # Actually not possible for an interp to destroy itself.
- interp delete {}
- return}
+ suicide
+ }
set chan [chan create {r w} foo]
fconfigure $chan -buffering none
set chan
}]
+ interp alias $ida suicide {} interp delete $ida
# Move channel to 2nd thread.
interp eval $ida [list testchannel cut $chan]
@@ -2002,8 +2100,7 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m
set res
}]
set res
-} -constraints {testchannel impossible} \
- -result {Owner lost}
+} -constraints {testchannel} -result {Owner lost}
test iocmd-32.2 {delete interp of reflected chan} {
# Bug 3034840
@@ -2726,10 +2823,11 @@ test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \
set res
} -cleanup {
+ after cancel $::timer
rename LOG {}
rename POST {}
rename HANDLER {}
- unset beat drive data forever res tid ch
+ unset beat drive data forever res tid ch timer
} -match glob \
-result {{initialize rc* read} {watch rc* read} {read rc* 4096} {watch rc* {}} {watch rc* read} {read rc* 4096} {watch rc* {}} {finalize rc*}}
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
index 5a8874c..c40621b 100644
--- a/tests/ioTrans.test
+++ b/tests/ioTrans.test
@@ -539,7 +539,46 @@ test iortrans-4.8 {chan read, read, bug 2921116} -setup {
tempdone
rename foo {}
} -result {{read rt* {test data
-}} file*}
+}} {}}
+test iortrans-4.8.1 {chan read, bug 721ec69271} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {fd args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ # Kill and recreate transform while it is operating
+ chan pop $fd
+ chan push $fd [list foo $fd]
+ }
+ set c [chan push [set c [tempchan]] [list foo $c]]
+ chan configure $c -buffersize 2
+ lappend res [read $c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{read rt* te} {read rt* st} {read rt* { d}} {read rt* at} {read rt* {a
+}} {}}
+test iortrans-4.8.2 {chan read, bug 721ec69271} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {fd args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ # Kill and recreate transform while it is operating
+ chan pop $fd
+ chan push $fd [list foo $fd]
+ return x
+ }
+ set c [chan push [set c [tempchan]] [list foo $c]]
+ chan configure $c -buffersize 1
+ lappend res [read $c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{read rt* t} {read rt* e} {read rt* s} {read rt* t} {read rt* { }} {read rt* d} {read rt* a} {read rt* t} {read rt* a} {read rt* {
+}} {}}
test iortrans-4.9 {chan read, gets, bug 2921116} -setup {
set res {}
} -match glob -body {
@@ -557,7 +596,7 @@ test iortrans-4.9 {chan read, gets, bug 2921116} -setup {
tempdone
rename foo {}
} -result {{read rt* {test data
-}} file*}
+}} {}}
# --- === *** ###########################
# method write (via puts)
@@ -995,7 +1034,7 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces
# Magic to get the test* commands in the slaves
load {} Tcltest $ida
load {} Tcltest $idb
-} -constraints {testchannel impossible} -match glob -body {
+} -constraints {testchannel} -match glob -body {
# Set up channel in thread
set chan [interp eval $ida $helperscript]
set chan [interp eval $ida {
@@ -1003,14 +1042,14 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces
handle.initialize clear drain flush limit? read write
handle.finalize
lappend ::res $args
- # Destroy interpreter during channel access. Actually not
- # possible for an interp to destroy itself.
- interp delete {}
- return}
+ # Destroy interpreter during channel access.
+ suicide
+ }
set chan [chan push [tempchan] foo]
fconfigure $chan -buffering none
set chan
}]
+ interp alias $ida suicide {} interp delete $ida
# Move channel to 2nd thread, transform goes with it.
interp eval $ida [list testchannel cut $chan]
interp eval $idb [list testchannel splice $chan]
diff --git a/tests/iogt.test b/tests/iogt.test
index d4c31d2..6cc0542 100644
--- a/tests/iogt.test
+++ b/tests/iogt.test
@@ -220,6 +220,36 @@ proc id_fulltrail {var op data} {
return $res
}
+proc id_torture {chan op data} {
+ switch -- $op {
+ create/write -
+ create/read -
+ delete/write -
+ delete/read -
+ clear_read {;#ignore}
+ flush/write -
+ flush/read {}
+ write {
+ global level
+ if {$level} {
+ return
+ }
+ incr level
+ testchannel unstack $chan
+ testchannel transform $chan \
+ -command [namespace code [list id_torture $chan]]
+ return $data
+ }
+ read {
+ testchannel unstack $chan
+ testchannel transform $chan \
+ -command [namespace code [list id_torture $chan]]
+ return $data
+ }
+ query/maxRead {return -1}
+ }
+}
+
proc counter {var op data} {
namespace upvar [namespace current] $var n
@@ -280,7 +310,7 @@ proc counter_audit {var vtrail op data} {
}
proc rblocks {var vtrail n op data} {
- namespace upvar [namespace current] $var n $vtrail trail
+ namespace upvar [namespace current] $var buf $vtrail trail
set res {}
@@ -326,6 +356,11 @@ proc audit_ops {var -attach channel} {
proc audit_flow {var -attach channel} {
testchannel transform $channel -command [namespace code [list id_fulltrail $var]]
}
+
+proc torture {-attach channel} {
+ testchannel transform $channel -command [namespace code [list id_torture $channel]]
+}
+
proc stopafter {var n -attach channel} {
namespace upvar [namespace current] $var vn
set vn $n
@@ -445,6 +480,7 @@ query/maxRead
read
query/maxRead
flush/read
+query/maxRead
delete/read
--------
create/write
@@ -491,6 +527,7 @@ read {
}
query/maxRead {} -1
flush/read {} {}
+query/maxRead {} -1
delete/read {} *ignored*
--------
create/write {} *ignored*
@@ -542,15 +579,35 @@ write %^&*()_+-= %^&*()_+-=
write {
} {
}
+query/maxRead {} -1
delete/read {} *ignored*
flush/write {} {}
delete/write {} *ignored*}
+test iogt-2.4 {basic I/O, mixed trail} {testchannel} {
+ set fh [open $path(dummy) r]
+ torture -attach $fh
+ chan configure $fh -buffersize 2
+ set x [read $fh]
+ testchannel unstack $fh
+ close $fh
+ set x
+} {}
+test iogt-2.5 {basic I/O, mixed trail} {testchannel} {
+ set ::level 0
+ set fh [open $path(dummyout) w]
+ torture -attach $fh
+ puts -nonewline $fh abcdef
+ flush $fh
+ testchannel unstack $fh
+ close $fh
+} {}
+
test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup {
proc DoneCopy {n {err {}}} {
variable copy 1
}
-} -constraints {testchannel hangs} -body {
+} -constraints {testchannel knownBug} -body {
# This test to check the validity of aquired Tcl_Channel references is not
# possible because even a backgrounded fcopy will immediately start to
# copy data, without waiting for the event loop. This is done only in case
@@ -561,6 +618,7 @@ test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup {
# delay, causing the fcopy to underflow immediately.
set fin [open $path(dummy) r]
fevent 1000 500 {20 20 20 10 1 1} {
+ variable copy
close $fin
set fout [open dummyout w]
flush $sock; # now, or fcopy will error us out
@@ -594,23 +652,30 @@ test iogt-4.0 {fileevent readable, after transform} -setup {
proc Done {args} {
variable stop 1
}
-} -constraints {testchannel hangs} -body {
+ proc Get {sock} {
+ variable trail
+ variable got
+ if {[eof $sock]} {
+ Done
+ lappend trail "xxxxxxxxxxxxx"
+ close $sock
+ return
+ }
+ lappend trail "vvvvvvvvvvvvv"
+ lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]"
+ lappend trail "============="
+ #puts stdout $__ ; flush stdout
+ #read $sock
+ }
+
+} -constraints {testchannel knownBug} -body {
fevent 1000 500 {20 20 20 10 1} {
+ variable stop
audit_flow trail -attach $sock
rblocks_t rbuf trail 23 -attach $sock
- fileevent $sock readable [namespace code {
- if {[eof $sock]} {
- Done
- lappend trail "xxxxxxxxxxxxx"
- close $sock
- } else {
- lappend trail "vvvvvvvvvvvvv"
- lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]"
- lappend trail "============="
- #puts stdout $__; flush stdout
- #read $sock
- }
- }]
+
+ fileevent $sock readable [namespace code [list Get $sock]]
+
flush $sock; # Now, or fcopy will error us out
# But the 1 second delay should be enough to initialize everything
# else here.
@@ -619,6 +684,7 @@ test iogt-4.0 {fileevent readable, after transform} -setup {
join [list [join $got \n] ~~~~~~~~ [join $trail \n]] \n
} -cleanup {
rename Done {}
+ rename Get {}
} -result {[[]]
[[abcdefghijklmnopqrstuvw]]
[[xyz0123456789,./?><;'\|]]
@@ -706,7 +772,7 @@ test iogt-5.0 {EOF simulation} -setup {
set fin [open $path(dummy) r]
set fout [open $path(dummyout) w]
set trail [list]
-} -constraints {testchannel unknownFailure} -result {
+} -constraints {testchannel knownBug} -result {
audit_flow trail -attach $fin
stopafter_audit d trail 20 -attach $fin
audit_flow trail -attach $fout
@@ -785,6 +851,15 @@ test iogt-6.0 {Push back} -constraints testchannel -body {
close $f
} -result {xxx}
test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body {
+
+ # This test demonstrates the bug/misfeature in the stacked
+ # channel implementation that data can be discarded if it is
+ # read into the buffers of one channel in the stack, and then
+ # that channel is popped before anything above it reads.
+ #
+ # This bug can be worked around by always setting -buffersize
+ # to 1, but who wants to do that?
+
set f [open $path(dummy) r]
# contents of dummy = "abcdefghi..."
read $f 3; # skip behind "abc"
diff --git a/tests/namespace.test b/tests/namespace.test
index 8c4b81c..cded1f4 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -303,7 +303,7 @@ test namespace-9.4 {Tcl_Import, simple import} {
}
test_ns_import::p
} {cmd1: 123}
-test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} {
+test namespace-9.5 {Tcl_Import, RFE 1230597} {
list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg
} {0 {}}
test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} {
@@ -2949,6 +2949,10 @@ test namespace-54.1 {leak on namespace deletion} -constraints {memory} \
rename getbytes {}
unset i ns start end
} -result 0
+
+test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a01} {
+ info class [format %s constructor] oo::object
+} ""
# cleanup
catch {rename cmd1 {}}
diff --git a/tests/obj.test b/tests/obj.test
index 71a39b4..151abfb 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -605,7 +605,7 @@ test obj-33.2 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
set x 0xffff; append x ffff
list [string is integer $x] [expr { wide($x) }]
} {1 4294967295}
-test obj-33.3 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
+test obj-33.3 {integer overflow on input} {
set x 0x10000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {0 4294967296}
@@ -621,7 +621,7 @@ test obj-33.6 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
set x -0xffff; append x ffff
list [string is integer $x] [expr { wide($x) }]
} {1 -4294967295}
-test obj-33.7 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
+test obj-33.7 {integer overflow on input} {
set x -0x10000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {0 -4294967296}
diff --git a/tests/regexp.test b/tests/regexp.test
index 1b2bec9..a83c99b 100644
--- a/tests/regexp.test
+++ b/tests/regexp.test
@@ -241,13 +241,13 @@ test regexp-5.5 {exercise cache of compiled expressions} {
test regexp-6.1 {regexp errors} {
list [catch {regexp a} msg] $msg
-} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}}
+} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexp-6.2 {regexp errors} {
list [catch {regexp -nocase a} msg] $msg
-} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}}
+} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexp-6.3 {regexp errors} {
list [catch {regexp -gorp a} msg] $msg
-} {1 {bad switch "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
+} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexp-6.4 {regexp errors} {
list [catch {regexp a( b} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
@@ -441,19 +441,19 @@ test regexp-10.5 {inverse partial newline sensitivity in regsub} {
test regexp-11.1 {regsub errors} {
list [catch {regsub a b} msg] $msg
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.2 {regsub errors} {
list [catch {regsub -nocase a b} msg] $msg
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.3 {regsub errors} {
list [catch {regsub -nocase -all a b} msg] $msg
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.4 {regsub errors} {
list [catch {regsub a b c d e f} msg] $msg
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.5 {regsub errors} {
list [catch {regsub -gorp a b c} msg] $msg
-} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
+} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
test regexp-11.6 {regsub errors} {
list [catch {regsub -nocase a( b c d} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
diff --git a/tests/regexpComp.test b/tests/regexpComp.test
index 94fb90e..7be1195 100644
--- a/tests/regexpComp.test
+++ b/tests/regexpComp.test
@@ -316,17 +316,17 @@ test regexpComp-6.1 {regexp errors} {
evalInProc {
list [catch {regexp a} msg] $msg
}
-} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}}
+} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexpComp-6.2 {regexp errors} {
evalInProc {
list [catch {regexp -nocase a} msg] $msg
}
-} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}}
+} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexpComp-6.3 {regexp errors} {
evalInProc {
list [catch {regexp -gorp a} msg] $msg
}
-} {1 {bad switch "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
+} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexpComp-6.4 {regexp errors} {
evalInProc {
list [catch {regexp a( b} msg] $msg
@@ -562,27 +562,27 @@ test regexpComp-11.1 {regsub errors} {
evalInProc {
list [catch {regsub a b} msg] $msg
}
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexpComp-11.2 {regsub errors} {
evalInProc {
list [catch {regsub -nocase a b} msg] $msg
}
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexpComp-11.3 {regsub errors} {
evalInProc {
list [catch {regsub -nocase -all a b} msg] $msg
}
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexpComp-11.4 {regsub errors} {
evalInProc {
list [catch {regsub a b c d e f} msg] $msg
}
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexpComp-11.5 {regsub errors} {
evalInProc {
list [catch {regsub -gorp a b c} msg] $msg
}
-} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
+} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
test regexpComp-11.6 {regsub errors} {
evalInProc {
list [catch {regsub -nocase a( b c d} msg] $msg
diff --git a/tests/socket.test b/tests/socket.test
index 51219e6..2bd2731 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -86,8 +86,21 @@ puts $s2 test1; gets $s1
puts $s2 test2; gets $s1
close $s1; close $s2
set t2 [clock milliseconds]
-set latency [expr {($t2-$t1)*2}]; # doubled as a safety margin
-unset t1 t2 s1 s2 server
+set lat1 [expr {($t2-$t1)*2}]; # doubled as a safety margin
+
+# Test the latency of failed connection attempts over the loopback
+# interface. They can take more than a second under Windowos and requres
+# additional [after]s in some tests that are not needed on systems that fail
+# immediately.
+set t1 [clock milliseconds]
+catch {socket 127.0.0.1 [randport]}
+set t2 [clock milliseconds]
+set lat2 [expr {($t2-$t1)*3}]
+
+# Use the maximum of the two latency calculations, but at least 100ms
+set latency [expr {$lat1 > $lat2 ? $lat1 : $lat2}]
+set latency [expr {$latency > 100 ? $latency : 1000}]
+unset t1 t2 s1 s2 lat1 lat2 server
# If remoteServerIP or remoteServerPort are not set, check in the environment
# variables for externally set values.
@@ -124,7 +137,6 @@ foreach {af localhost} {
testConstraint supported_$af [expr {![catch {socket -server foo -myaddr $localhost 0} sock]}]
catch {close $sock}
}
-testConstraint supported_any [expr {[testConstraint supported_inet] || [testConstraint supported_inet6]}]
set sock [socket -server foo -myaddr localhost 0]
set sockname [fconfigure $sock -sockname]
@@ -138,6 +150,9 @@ foreach {af localhost} {
inet 127.0.0.1
inet6 ::1
} {
+ if {![testConstraint supported_$af]} {
+ continue
+ }
set ::tcl::unsupported::socketAF $af
#
# Check if we're supposed to do tests against the remote server
@@ -625,6 +640,86 @@ test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$a
close $s
close $sock
} -result {a:one b: c:two}
+test socket_$af-2.12 {} [list socket stdio supported_$af] {
+ file delete $path(script)
+ set f [open $path(script) w]
+ puts $f {
+ set server [socket -server accept_client 0]
+ puts [lindex [chan configure $server -sockname] 2]
+ proc accept_client { client host port } {
+ chan configure $client -blocking 0 -buffering line
+ write_line $client
+ }
+ proc write_line client {
+ if { [catch { chan puts $client [string repeat . 720000]}] } {
+ puts [catch {chan close $client}]
+ } else {
+ puts signal1
+ after 0 write_line $client
+ }
+ }
+ chan event stdin readable {set forever now}
+ vwait forever
+ exit
+ }
+ close $f
+ set f [open "|[list [interpreter] $path(script)]" r+]
+ gets $f port
+ set sock [socket $localhost $port]
+ chan event $sock readable [list read_lines $sock $f]
+ proc read_lines { sock pipe } {
+ gets $pipe
+ chan close $sock
+ chan event $pipe readable [list readpipe $pipe]
+ }
+ proc readpipe {pipe} {
+ while {![string is integer [set ::done [gets $pipe]]]} {}
+ }
+ vwait ::done
+ close $f
+ set ::done
+} 0
+test socket_$af-2.13 {Bug 1758a0b603} {socket stdio} {
+ file delete $path(script)
+ set f [open $path(script) w]
+ puts $f {
+ set server [socket -server accept 0]
+ puts [lindex [chan configure $server -sockname] 2]
+ proc accept { client host port } {
+ chan configure $client -blocking 0 -buffering line -buffersize 1
+ puts $client [string repeat . 720000]
+ puts ready
+ chan event $client writable [list setup $client]
+ }
+ proc setup client {
+ chan event $client writable {set forever write}
+ after 5 {set forever timeout}
+ }
+ vwait forever
+ puts $forever
+ }
+ close $f
+ set pipe [open |[list [interpreter] $path(script)] r]
+ gets $pipe port
+ set sock [socket $localhost $port]
+ chan configure $sock -blocking 0 -buffering line
+ chan event $sock readable [list read_lines $sock $pipe ]
+ proc read_lines { sock pipe } {
+ gets $pipe
+ gets $sock line
+ after idle [list stop $sock $pipe]
+ chan event $sock readable {}
+ }
+ proc stop {sock pipe} {
+ variable done
+ close $sock
+ set done [gets $pipe]
+ }
+ variable done
+ vwait [namespace which -variable done]
+ close $pipe
+ set done
+} write
test socket_$af-3.1 {socket conflict} -constraints [list socket supported_$af stdio] -setup {
file delete $path(script)
@@ -1560,8 +1655,8 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup {
close $f
# If the socket doesn't hit end-of-file in 10 seconds, the script1 process
# must have inherited the client.
- set failed 0
- set after [after 10000 [list set failed 1]]
+ set timeout 0
+ set after [after 10000 {set x "client socket was inherited"}]
} -constraints [list socket supported_$af stdio exec] -body {
# Create the server socket
set server [socket -server accept -myaddr $localhost 0]
@@ -1571,26 +1666,20 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup {
close $server
fileevent $file readable [list getdata $file]
fconfigure $file -buffering line -blocking 0
+ set ::f $file
}
proc getdata { file } {
# Read handler on the accepted socket.
- global x failed
+ global x
set status [catch {read $file} data]
if {$status != 0} {
- set x {read failed, error was $data}
- catch { close $file }
+ set x "read failed, error was $data"
} elseif {$data ne ""} {
} elseif {[fblocked $file]} {
} elseif {[eof $file]} {
- if {$failed} {
- set x {client socket was inherited}
- } else {
- set x {client socket was not inherited}
- }
- catch { close $file }
+ set x "client socket was not inherited"
} else {
- set x {impossible case}
- catch { close $file }
+ set x "impossible case"
}
}
# Launch the script2 process
@@ -1600,6 +1689,8 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup {
vwait x
return $x
} -cleanup {
+ fconfigure $f -blocking 1
+ close $f
after cancel $after
close $p
} -result {client socket was not inherited}
@@ -1641,35 +1732,30 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup {
# If the socket is still open after 5 seconds, the script1 process must
# have inherited the accepted socket.
set failed 0
- set after [after 5000 [list set failed 1]]
+ set after [after 5000 [list set x "accepted socket was inherited"]]
proc getdata { file } {
# Read handler on the client socket.
global x
global failed
set status [catch {read $file} data]
if {$status != 0} {
- set x {read failed, error was $data}
- catch { close $file }
+ set x "read failed, error was $data"
} elseif {[string compare {} $data]} {
} elseif {[fblocked $file]} {
} elseif {[eof $file]} {
- if {$failed} {
- set x {accepted socket was inherited}
- } else {
- set x {accepted socket was not inherited}
- }
- catch { close $file }
+ set x "accepted socket was not inherited"
} else {
- set x {impossible case}
- catch { close $file }
+ set x "impossible case"
}
return
}
vwait x
- return $x
+ set x
} -cleanup {
+ fconfigure $f -blocking 1
+ close $f
after cancel $after
- catch {close $p}
+ close $p
} -result {accepted socket was not inherited}
test socket_$af-13.1 {Testing use of shared socket between two threads} -body {
@@ -1723,8 +1809,8 @@ catch {close $commandSocket}
catch {close $remoteProcChan}
}
unset ::tcl::unsupported::socketAF
-test socket-14.0 {[socket -async] when server only listens on IPv4} \
- -constraints [list socket supported_any localhost_v4] \
+test socket-14.0.0 {[socket -async] when server only listens on IPv4} \
+ -constraints {socket supported_inet localhost_v4} \
-setup {
proc accept {s a p} {
global x
@@ -1736,7 +1822,29 @@ test socket-14.0 {[socket -async] when server only listens on IPv4} \
set port [lindex [fconfigure $server -sockname] 2]
} -body {
set client [socket -async localhost $port]
- set after [after 1000 {set x [fconfigure $client -error]}]
+ set after [after $latency {set x [fconfigure $client -error]}]
+ vwait x
+ set x
+ } -cleanup {
+ after cancel $after
+ close $server
+ close $client
+ unset x
+ } -result ok
+test socket-14.0.1 {[socket -async] when server only listens on IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ proc accept {s a p} {
+ global x
+ puts $s bye
+ close $s
+ set x ok
+ }
+ set server [socket -server accept -myaddr ::1 0]
+ set port [lindex [fconfigure $server -sockname] 2]
+ } -body {
+ set client [socket -async localhost $port]
+ set after [after $latency {set x [fconfigure $client -error]}]
vwait x
set x
} -cleanup {
@@ -1746,7 +1854,7 @@ test socket-14.0 {[socket -async] when server only listens on IPv4} \
unset x
} -result ok
test socket-14.1 {[socket -async] fileevent while still connecting} \
- -constraints [list socket supported_any] \
+ -constraints {socket} \
-setup {
proc accept {s a p} {
global x
@@ -1763,7 +1871,7 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \
lappend x [fconfigure $client -error]
fileevent $client writable {}
}
- set after [after 1000 {lappend x timeout}]
+ set after [after $latency {lappend x timeout}]
while {[llength $x] < 2 && "timeout" ni $x} {
vwait x
}
@@ -1775,26 +1883,21 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \
unset x
} -result {{} ok}
test socket-14.2 {[socket -async] fileevent connection refused} \
- -constraints [list socket supported_any] \
+ -constraints {socket} \
-body {
- if {[catch {socket -async localhost [randport]} client]} {
- regexp {[^:]*: (.*)} $client -> x
- } else {
- fileevent $client writable {set x [fconfigure $client -error]}
- set after [after 1000 {set x timeout}]
- vwait x
- after cancel $after
- if {$x eq "timeout"} {
- append x ": [fconfigure $client -error]"
- }
- close $client
- }
- set x
+ set client [socket -async localhost [randport]]
+ fileevent $client writable {set x ok}
+ set after [after $latency {set x timeout}]
+ vwait x
+ after cancel $after
+ lappend x [fconfigure $client -error]
} -cleanup {
- unset x
- } -result "connection refused"
+ after cancel $after
+ close $client
+ unset x after client
+ } -result {ok {connection refused}}
test socket-14.3 {[socket -async] when server only listens on IPv6} \
- -constraints [list socket supported_any localhost_v6] \
+ -constraints {socket supported_inet6 localhost_v6} \
-setup {
proc accept {s a p} {
global x
@@ -1806,7 +1909,7 @@ test socket-14.3 {[socket -async] when server only listens on IPv6} \
set port [lindex [fconfigure $server -sockname] 2]
} -body {
set client [socket -async localhost $port]
- set after [after 1000 {set x [fconfigure $client -error]}]
+ set after [after $latency {set x [fconfigure $client -error]}]
vwait x
set x
} -cleanup {
@@ -1816,7 +1919,7 @@ test socket-14.3 {[socket -async] when server only listens on IPv6} \
unset x
} -result ok
test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \
- -constraints [list socket supported_any] \
+ -constraints {socket} \
-setup {
proc accept {s a p} {
puts $s bye
@@ -1832,7 +1935,7 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \
fileevent $client writable {}
}
fileevent $client readable {lappend x [gets $client]}
- set after [after 1000 {lappend x timeout}]
+ set after [after $latency {lappend x timeout}]
while {[llength $x] < 2 && "timeout" ni $x} {
vwait x
}
@@ -1843,20 +1946,23 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \
close $server
unset x
} -result {{} bye}
+# FIXME: we should also have an IPv6 counterpart of this
test socket-14.5 {[socket -async] which fails before any connect() can be made} \
- -constraints [list socket supported_any] \
+ -constraints {socket supported_inet} \
-body {
# address from rfc5737
socket -async -myaddr 192.0.2.42 127.0.0.1 [randport]
} \
-returnCodes 1 \
-result {couldn't open socket: cannot assign requested address}
-test socket-14.6 {[socket -async] with no event loop and [fconfigure -error] before the socket is connected} \
- -constraints [list socket supported_inet supported_inet6] \
+test socket-14.6.0 {[socket -async] with no event loop and server listening on IPv4} \
+ -constraints {socket supported_inet localhost_v4} \
-setup {
proc accept {s a p} {
+ global x
puts $s bye
close $s
+ set x ok
}
set server [socket -server accept -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $server -sockname] 2]
@@ -1864,19 +1970,390 @@ test socket-14.6 {[socket -async] with no event loop and [fconfigure -error] bef
} \
-body {
set client [socket -async localhost $port]
- foreach _ {1 2} {
- lappend x [lindex [fconfigure $client -sockname] 0]
- lappend x [fconfigure $client -error]
+ for {set i 0} {$i < 50} {incr i } {
update
+ if {$x ne ""} {
+ lappend x [gets $client]
+ break
+ }
+ after 100
}
- lappend x [gets $client]
+ set x
} \
-cleanup {
close $server
close $client
unset x
} \
- -result [list ::1 "connection refused" 127.0.0.1 "" bye]
+ -result {ok bye}
+test socket-14.6.1 {[socket -async] with no event loop and server listening on IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ proc accept {s a p} {
+ global x
+ puts $s bye
+ close $s
+ set x ok
+ }
+ set server [socket -server accept -myaddr ::1 0]
+ set port [lindex [fconfigure $server -sockname] 2]
+ set x ""
+ } \
+ -body {
+ set client [socket -async localhost $port]
+ for {set i 0} {$i < 50} {incr i } {
+ update
+ if {$x ne ""} {
+ lappend x [gets $client]
+ break
+ }
+ after 100
+ }
+ set x
+ } \
+ -cleanup {
+ close $server
+ close $client
+ unset x
+ } \
+ -result {ok bye}
+test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} \
+ -constraints {socket supported_inet localhost_v4} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr 127.0.0.1 0]
+ proc accept {s h p} {puts $s ok; close $s; set ::x 1}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error]
+ } -cleanup {
+ close $fd
+ close $sock
+ } -result {{} ok {}}
+test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr ::1 0]
+ proc accept {s h p} {puts $s ok; close $s; set ::x 1}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error]
+ } -cleanup {
+ close $fd
+ close $sock
+ } -result {{} ok {}}
+test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} \
+ -constraints {socket} \
+ -body {
+ set sock [socket -async localhost [randport]]
+ catch {gets $sock} x
+ list $x [fconfigure $sock -error] [fconfigure $sock -error]
+ } -cleanup {
+ close $sock
+ } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}}
+test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IPv4} \
+ -constraints {socket supported_inet localhost_v4} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr 127.0.0.1 0]
+ proc accept {s h p} {puts $s ok; close $s; set ::x 1}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ fconfigure $sock -blocking 0
+ for {set i 0} {$i < 50} {incr i } {
+ if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
+ after 200
+ }
+ set x
+ } -cleanup {
+ close $fd
+ close $sock
+ } -result {ok}
+test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr ::1 0]
+ proc accept {s h p} {puts $s ok; close $s; set ::x 1}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ fconfigure $sock -blocking 0
+ for {set i 0} {$i < 50} {incr i } {
+ if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
+ after 200
+ }
+ set x
+ } -cleanup {
+ close $fd
+ close $sock
+ } -result {ok}
+test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} \
+ -constraints {socket} \
+ -body {
+ set sock [socket -async localhost [randport]]
+ fconfigure $sock -blocking 0
+ for {set i 0} {$i < 50} {incr i } {
+ if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
+ after 200
+ }
+ list $x [fconfigure $sock -error] [fconfigure $sock -error]
+ } -cleanup {
+ close $sock
+ } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}}
+test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} \
+ -constraints {socket supported_inet localhost_v4} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr 127.0.0.1 0]
+ proc accept {s h p} {set ::x $s}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ puts [gets $x]
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ puts $sock ok
+ flush $sock
+ list [fconfigure $sock -error] [gets $fd]
+ } -cleanup {
+ close $fd
+ close $sock
+ } -result {{} ok}
+test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr ::1 0]
+ proc accept {s h p} {set ::x $s}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ puts [gets $x]
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ puts $sock ok
+ flush $sock
+ list [fconfigure $sock -error] [gets $fd]
+ } -cleanup {
+ close $fd
+ close $sock
+ } -result {{} ok}
+test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} \
+ -constraints {socket supported_inet localhost_v4} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr 127.0.0.1 0]
+ proc accept {s h p} {set ::x $s}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ puts [gets $x]
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ fconfigure $sock -blocking 0
+ puts $sock ok
+ flush $sock
+ fileevent $fd readable {set x 1}
+ vwait x
+ list [fconfigure $sock -error] [gets $fd]
+ } -cleanup {
+ close $fd
+ close $sock
+ } -result {{} ok}
+test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr ::1 0]
+ proc accept {s h p} {set ::x $s}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ puts [gets $x]
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ fconfigure $sock -blocking 0
+ puts $sock ok
+ flush $sock
+ fileevent $fd readable {set x 1}
+ vwait x
+ list [fconfigure $sock -error] [gets $fd]
+ } -cleanup {
+ close $fd
+ close $sock
+ } -result {{} ok}
+test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} \
+ -constraints {socket} \
+ -body {
+ set sock [socket -async localhost [randport]]
+ fconfigure $sock -blocking 0
+ puts $sock ok
+ fileevent $sock writable {set x 1}
+ vwait x
+ close $sock
+ } -cleanup {
+ catch {close $sock}
+ unset x
+ } -result {socket is not connected} -returnCodes 1
+test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \
+ -constraints {socket} \
+ -body {
+ set sock [socket -async localhost [randport]]
+ fconfigure $sock -blocking 0
+ puts $sock ok
+ flush $sock
+ fileevent $sock writable {set x 1}
+ vwait x
+ close $sock
+ } -cleanup {
+ catch {close $sock}
+ catch {unset x}
+ } -result {socket is not connected} -returnCodes 1
+test socket-14.12 {[socket -async] background progress triggered by [fconfigure -error]} \
+ -constraints {socket} \
+ -body {
+ set s [socket -async localhost [randport]]
+ for {set i 0} {$i < 50} {incr i} {
+ set x [fconfigure $s -error]
+ if {$x != ""} break
+ after 200
+ }
+ set x
+ } -cleanup {
+ close $s
+ unset x s
+ } -result {connection refused}
+
+test socket-14.13 {testing writable event when quick failure} \
+ -constraints {socket win supported_inet} \
+ -body {
+ # Test for bug 336441ed59 where a quick background fail was ignored
+
+ # Test only for windows as socket -async 255.255.255.255 fails
+ # directly on unix
+
+ # The following connect should fail very quickly
+ set a1 [after 2000 {set x timeout}]
+ set s [socket -async 255.255.255.255 43434]
+ fileevent $s writable {set x writable}
+ vwait x
+ set x
+} -cleanup {
+ catch {close $s}
+ after cancel $a1
+} -result writable
+
+test socket-14.14 {testing fileevent readable on failed async socket connect} \
+ -constraints {socket} -body {
+ # Test for bug 581937ab1e
+
+ set a1 [after 5000 {set x timeout}]
+ # This connect should fail
+ set s [socket -async localhost [randport]]
+ fileevent $s readable {set x readable}
+ vwait x
+ set x
+} -cleanup {
+ catch {close $s}
+ after cancel $a1
+} -result readable
+
+test socket-14.15 {blocking read on async socket should not trigger event handlers} \
+ -constraints socket -body {
+ set s [socket -async localhost [randport]]
+ set x ok
+ fileevent $s writable {set x fail}
+ catch {read $s}
+ set x
+ } -result ok
+
+set num 0
+
+set x {localhost {socket} 127.0.0.1 {supported_inet} ::1 {supported_inet6}}
+set resultok {-result "sock*" -match glob}
+set resulterr {
+ -result {couldn't open socket: connection refused}
+ -returnCodes 1
+}
+foreach {servip sc} $x {
+ foreach {cliip cc} $x {
+ set constraints socket
+ lappend constraints $sc $cc
+ set result $resulterr
+ switch -- [lsort -unique [list $servip $cliip]] {
+ localhost - 127.0.0.1 - ::1 {
+ set result $resultok
+ }
+ {127.0.0.1 localhost} {
+ if {[testConstraint localhost_v4]} {
+ set result $resultok
+ }
+ }
+ {::1 localhost} {
+ if {[testConstraint localhost_v6]} {
+ set result $resultok
+ }
+ }
+ }
+ test socket-15.1.$num "Connect to $servip from $cliip" \
+ -constraints $constraints -setup {
+ set server [socket -server accept -myaddr $servip 0]
+ proc accept {s h p} { close $s }
+ set port [lindex [fconfigure $server -sockname] 2]
+ } -body {
+ set s [socket $cliip $port]
+ } -cleanup {
+ close $server
+ catch {close $s}
+ } {*}$result
+ incr num
+ }
+}
::tcltest::cleanupTests
flush stdout
diff --git a/tests/string.test b/tests/string.test
index 740cdc6..a8a83d9 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -1398,6 +1398,9 @@ test string-15.9 {string tolower} {
test string-15.10 {string tolower, unicode} {
string tolower ABCabc\xc7\xe7
} "abcabc\xe7\xe7"
+test string-15.11 {string tolower, compiled} {
+ lindex [string tolower [list A B [list C]]] 1
+} b
test string-16.1 {string toupper} {
list [catch {string toupper} msg] $msg
@@ -1429,6 +1432,9 @@ test string-16.9 {string toupper} {
test string-16.10 {string toupper, unicode} {
string toupper ABCabc\xc7\xe7
} "ABCABC\xc7\xc7"
+test string-16.11 {string toupper, compiled} {
+ lindex [string toupper [list a b [list c]]] 1
+} B
test string-17.1 {string totitle} {
list [catch {string totitle} msg] $msg
@@ -1451,6 +1457,9 @@ test string-17.6 {string totitle, unicode} {
test string-17.7 {string totitle, unicode} {
string totitle \u01f3BCabc\xc7\xe7
} "\u01f2bcabc\xe7\xe7"
+test string-17.8 {string totitle, compiled} {
+ lindex [string totitle [list aa bb [list cc]]] 0
+} Aa
test string-18.1 {string trim} {
list [catch {string trim} msg] $msg
@@ -1792,8 +1801,8 @@ test string-26.7 {tcl::prefix} -body {
tcl::prefix match -exact {apa bepa cepa depa} be
} -returnCodes 1 -result {bad option "be": must be apa, bepa, cepa, or depa}
test string-26.8 {tcl::prefix} -body {
- tcl::prefix match -message switch {apa bepa bear depa} be
-} -returnCodes 1 -result {ambiguous switch "be": must be apa, bepa, bear, or depa}
+ tcl::prefix match -message wombat {apa bepa bear depa} be
+} -returnCodes 1 -result {ambiguous wombat "be": must be apa, bepa, bear, or depa}
test string-26.9 {tcl::prefix} -body {
tcl::prefix match -error {} {apa bepa bear depa} be
} -returnCodes 0 -result {}
diff --git a/tests/stringComp.test b/tests/stringComp.test
index 9e00ce7..165ef20 100644
--- a/tests/stringComp.test
+++ b/tests/stringComp.test
@@ -26,6 +26,22 @@ catch [list package require -exact Tcltest [info patchlevel]]
# Some tests require the testobj command
testConstraint testobj [expr {[info commands testobj] != {}}]
+testConstraint memory [llength [info commands memory]]
+if {[testConstraint memory]} {
+ proc getbytes {} {
+ set lines [split [memory info] \n]
+ return [lindex $lines 3 3]
+ }
+ proc leaktest {script {iterations 3}} {
+ set end [getbytes]
+ for {set i 0} {$i < $iterations} {incr i} {
+ uplevel 1 $script
+ set tmp $end
+ set end [getbytes]
+ }
+ return [expr {$end - $tmp}]
+ }
+}
test stringComp-1.1 {error conditions} {
proc foo {} {string gorp a b}
@@ -687,7 +703,23 @@ test stringComp-12.1 {Bug 3588366: end-offsets before start} {
## not yet bc
## string replace
-## not yet bc
+test stringComp-14.1 {Bug 82e7f67325} {
+ apply {x {
+ set a [join $x {}]
+ lappend b [string length [string replace ___! 0 2 $a]]
+ lappend b [string length [string replace ___! 0 2 $a[unset a]]]
+ }} {a b}
+} {3 3}
+test stringComp-14.2 {Bug 82e7f67325} memory {
+ # As in stringComp-14.1, but make sure we don't retain too many refs
+ leaktest {
+ apply {x {
+ set a [join $x {}]
+ lappend b [string length [string replace ___! 0 2 $a]]
+ lappend b [string length [string replace ___! 0 2 $a[unset a]]]
+ }} {a b}
+ }
+} {0}
## string tolower
## not yet bc
diff --git a/tests/subst.test b/tests/subst.test
index 7466895..498512d 100644
--- a/tests/subst.test
+++ b/tests/subst.test
@@ -21,7 +21,7 @@ test subst-1.1 {basics} -returnCodes error -body {
} -result {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}
test subst-1.2 {basics} -returnCodes error -body {
subst a b c
-} -result {bad switch "a": must be -nobackslashes, -nocommands, or -novariables}
+} -result {bad option "a": must be -nobackslashes, -nocommands, or -novariables}
test subst-2.1 {simple strings} {
subst {}
@@ -119,13 +119,13 @@ test subst-6.1 {clear the result after command substitution} -body {
test subst-7.1 {switches} -returnCodes error -body {
subst foo bar
-} -result {bad switch "foo": must be -nobackslashes, -nocommands, or -novariables}
+} -result {bad option "foo": must be -nobackslashes, -nocommands, or -novariables}
test subst-7.2 {switches} -returnCodes error -body {
subst -no bar
-} -result {ambiguous switch "-no": must be -nobackslashes, -nocommands, or -novariables}
+} -result {ambiguous option "-no": must be -nobackslashes, -nocommands, or -novariables}
test subst-7.3 {switches} -returnCodes error -body {
subst -bogus bar
-} -result {bad switch "-bogus": must be -nobackslashes, -nocommands, or -novariables}
+} -result {bad option "-bogus": must be -nobackslashes, -nocommands, or -novariables}
test subst-7.4 {switches} {
set x 123
subst -nobackslashes {abc $x [expr 1+2] \\\x41}
diff --git a/tests/switch.test b/tests/switch.test
index a03948b..4d204bb 100644
--- a/tests/switch.test
+++ b/tests/switch.test
@@ -169,7 +169,7 @@ test switch-4.1 {error in executed command} {
"switch a a {error "Just a test"} default {subst 1}"}}
test switch-4.2 {error: not enough args} -returnCodes error -body {
switch
-} -result {wrong # args: should be "switch ?-switch ...? string ?pattern body ...? ?default body?"}
+} -result {wrong # args: should be "switch ?-option ...? string ?pattern body ...? ?default body?"}
test switch-4.3 {error: pattern with no body} -body {
switch a b
} -returnCodes error -result {extra switch pattern with no body}
@@ -269,16 +269,16 @@ test switch-8.3 {weird body text, variable} {
test switch-9.1 {empty pattern/body list} -returnCodes error -body {
switch x
-} -result {wrong # args: should be "switch ?-switch ...? string ?pattern body ...? ?default body?"}
+} -result {wrong # args: should be "switch ?-option ...? string ?pattern body ...? ?default body?"}
test switch-9.2 {unpaired pattern} -returnCodes error -body {
switch -- x
} -result {extra switch pattern with no body}
test switch-9.3 {empty pattern/body list} -body {
switch x {}
-} -returnCodes error -result {wrong # args: should be "switch ?-switch ...? string {?pattern body ...? ?default body?}"}
+} -returnCodes error -result {wrong # args: should be "switch ?-option ...? string {?pattern body ...? ?default body?}"}
test switch-9.4 {empty pattern/body list} -body {
switch -- x {}
-} -returnCodes error -result {wrong # args: should be "switch ?-switch ...? string {?pattern body ...? ?default body?}"}
+} -returnCodes error -result {wrong # args: should be "switch ?-option ...? string {?pattern body ...? ?default body?}"}
test switch-9.5 {unpaired pattern} -body {
switch x a {} b
} -returnCodes error -result {extra switch pattern with no body}
diff --git a/tests/winFCmd.test b/tests/winFCmd.test
index 28a0e9f..28257c6 100644
--- a/tests/winFCmd.test
+++ b/tests/winFCmd.test
@@ -208,22 +208,11 @@ test winFCmd-1.13 {TclpRenameFile: errno: EACCES} -setup {
} -constraints {win win2000orXP testfile} -body {
testfile mv nul tf1
} -returnCodes error -result EINVAL
-test winFCmd-1.13.1 {TclpRenameFile: errno: EACCES} -setup {
+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.13.2 {TclpRenameFile: errno: ENOENT} -setup {
- cleanup
-} -constraints {win 95 testfile} -body {
- testfile mv nul tf1
-} -returnCodes error -result ENOENT
-test winFCmd-1.14 {TclpRenameFile: errno: EACCES} -setup {
- cleanup
-} -constraints {win 95 testfile} -body {
- createfile tf1
- testfile mv tf1 nul
-} -returnCodes error -result EACCES
test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} -setup {
cleanup
} -constraints {win nt testfile} -body {
@@ -257,11 +246,6 @@ test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} -setup {
} -constraints {win nt winOlderThan2000 testfile} -body {
testfile mv nul tf1
} -returnCodes error -result EACCES
-test winFCmd-1.19.2 {TclpRenameFile: errno == ENOENT} -setup {
- cleanup
-} -constraints {win 95 testfile} -body {
- testfile mv nul tf1
-} -returnCodes error -result ENOENT
test winFCmd-1.20 {TclpRenameFile: src is dir} -setup {
cleanup
} -constraints {win nt testfile} -body {
@@ -474,29 +458,14 @@ test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} -setup {
} -returnCodes error -result ENOENT
test winFCmd-2.7 {TclpCopyFile: errno: EACCES} -setup {
cleanup
-} -constraints {win 95 testfile} -body {
- createfile tf1
- set fd [open tf2 w]
- testfile cp tf1 tf2
-} -cleanup {
- close $fd
- cleanup
-} -returnCodes error -result EACCES
-test winFCmd-2.8 {TclpCopyFile: errno: EACCES} -setup {
- cleanup
} -constraints {win win2000orXP testfile} -body {
testfile cp nul tf1
} -returnCodes error -result EINVAL
-test winFCmd-2.8.1 {TclpCopyFile: errno: EACCES} -setup {
+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.9 {TclpCopyFile: errno: ENOENT} -setup {
- cleanup
-} -constraints {win 95 testfile} -body {
- testfile cp nul tf1
-} -returnCodes error -result ENOENT
test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} -setup {
cleanup
} -constraints {win testfile} -body {
@@ -573,17 +542,6 @@ test winFCmd-2.17 {TclpCopyFile: dst is readonly} -setup {
catch {testchmod 666 tf2}
cleanup
} -result {1 tf1}
-test winFCmd-2.18 {TclpCopyFile: still can't copy onto dst} -setup {
- cleanup
-} -constraints {win 95 testfile testchmod} -body {
- createfile tf1
- createfile tf2
- testchmod 000 tf2
- set fd [open tf2]
- set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
- close $fd
- lappend msg [file writable tf2]
-} -result {1 EACCES 0}
test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} -body {
testfile rm $cdfile $cdrom/dummy~~.fil
@@ -666,9 +624,6 @@ 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
-test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} -body {
- testfile mkdir $cdrom/dummy~~.dir
-} -constraints {win 95 cdrom testfile} -returnCodes error -result ENOSPC
test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} -setup {
cleanup
} -constraints {win testfile} -body {
@@ -764,11 +719,6 @@ test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup {
catch {testchmod 666 td1}
cleanup
} -result {td1 EACCES}
-test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} -setup {
- cleanup
-} -constraints {win 95 testfile} -body {
- testfile rmdir nul
-} -returnCodes error -result {nul EACCES}
test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup {
cleanup
} -constraints {win nt testfile} -body {
@@ -776,16 +726,6 @@ test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup {
# WinXP returns EEXIST, WinNT seems to return EACCES. No policy
# decision has been made as to which is correct.
} -returnCodes error -match regexp -result {^/ E(ACCES|EXIST)$}
-# This next test has a very hokey way of matching...
-test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} -setup {
- cleanup
-} -constraints {win 95 testfile} -body {
- createfile tf1
- set res [catch {testfile rmdir tf1} msg]
- # get rid of path
- set msg [list [file tail [lindex $msg 0]] [lindex $msg 1]]
- list $res $msg
-} -result {1 {tf1 ENOTDIR}}
test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup {
cleanup
} -constraints {winVista testfile testchmod} -body {
@@ -798,16 +738,6 @@ test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup {
cleanup
} -returnCodes error -result {td1 EACCES}
# This next test has a very hokey way of matching...
-test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} -setup {
- cleanup
-} -constraints {win 95 testfile} -body {
- file mkdir td1/td2
- set res [catch {testfile rmdir td1} msg]
- # get rid of path
- set msg [list [file tail [lindex $msg 0]] [lindex $msg 1]]
- list $res $msg
-} -result {1 {td1 EEXIST}}
-# This next test has a very hokey way of matching...
test winFCmd-6.15 {TclpRemoveDirectory: !recursive} -setup {
cleanup
} -constraints {win testfile} -body {
@@ -887,11 +817,6 @@ test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} -setup {
} -cleanup {
cleanup
} -result {tf1}
-test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} -body {
- # cdrom can return either d:\ or D:/, but we only care about the errcode
- testfile rmdir $cdrom/
-} -constraints {win 95 cdrom testfile} -returnCodes error -match glob \
- -result {* EACCES} ; # was EEXIST, but changed for win98.
test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} -body {
testfile rmdir $cdrom/
} -constraints {win nt cdrom testfile} -returnCodes error -match glob \
@@ -930,14 +855,6 @@ test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} -setup {
} -cleanup {
cleanup
} -result {tf1}
-test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} -setup {
- cleanup
-} -constraints {win 95 testfile} -body {
- file mkdir td1
- testfile cpdir td1 /
-} -cleanup {
- cleanup
-} -returnCodes error -result {/ EEXIST}
test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} -setup {
cleanup
} -constraints {win nt testfile} -body {
@@ -1038,15 +955,6 @@ test winFCmd-9.1 {TraversalDelete: DOTREE_F} -setup {
createfile td1/tf1
testfile rmdir -force td1
} -result {}
-test winFCmd-9.2 {TraversalDelete: DOTREE_F} -setup {
- cleanup
-} -constraints {win 95 testfile} -body {
- file mkdir td1
- set fd [open td1/tf1 w]
- testfile rmdir -force td1
-} -cleanup {
- close $fd
-} -returnCodes error -result {td1\tf1 EACCES}
test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup {
cleanup
} -constraints {winVista testfile testchmod} -body {
@@ -1477,10 +1385,10 @@ test winFCmd-19.5 {Windows extended path names} -constraints nt -setup {
list [catch {
set f [open $tmpfile [list WRONLY CREAT]]
close $f
- } res] errormsg ;#$res
+ } res] $res
} -cleanup {
catch {file delete $tmpfile}
-} -result [list 1 errormsg]
+} -result [list 0 {}]
test winFCmd-19.6 {Windows extended path names} -constraints nt -setup {
set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp]
set tmpfile //?/[file normalize $tmpfile]
diff --git a/tests/winFile.test b/tests/winFile.test
index fba9bcb..2c47f5f 100644
--- a/tests/winFile.test
+++ b/tests/winFile.test
@@ -37,24 +37,6 @@ test winFile-1.2 {TclpGetUserHome} -constraints {win nt nonPortable} -body {
# The administrator account should always exist.
glob ~administrator
} -match glob -result *
-test winFile-1.3 {TclpGetUserHome} -constraints {win 95} -body {
- # Find some user in system.ini and then see if they have a home.
-
- set f [open $::env(windir)/system.ini]
- while {[gets $f line] >= 0} {
- if {$line ne {[Password Lists]}} {
- continue
- }
- gets $f
- set name [lindex [split [gets $f] =] 0]
- if {$name ne ""} {
- return [catch {glob ~$name}]
- }
- }
- return 0 ;# didn't find anything...
-} -cleanup {
- catch {close $f}
-} -result {0}
test winFile-1.4 {TclpGetUserHome} {win nt nonPortable} {
catch {glob ~stanton@workgroup}
} {0}
diff --git a/tests/winPipe.test b/tests/winPipe.test
index d2e804d..9c6f94d 100644
--- a/tests/winPipe.test
+++ b/tests/winPipe.test
@@ -82,10 +82,6 @@ test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win nt exec cat3
exec [interpreter] $path(more) < $path(big) | $cat32 > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
-test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {win 95 exec cat32} {
- exec command /c type $path(big) |& $cat32 > $path(stdout) 2> $path(stderr)
- list [contents $path(stdout)] [contents $path(stderr)]
-} "{$big} stderr32"
test winpipe-1.6 {32 bit comprehensive tests: from console} \
{win cat32 AllocConsole} {
# would block waiting for human input
@@ -174,10 +170,6 @@ test winpipe-1.21 {32 bit comprehensive tests: read/write application} \
catch {close $f}
set r
} "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
-test winpipe-1.22 {Checking command.com for Win95/98 hanging} {win 95 exec} {
- exec command.com /c dir /b
- set result 1
-} 1
test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} {
proc readResults {f} {
diff --git a/tests/zlib.test b/tests/zlib.test
index 4e51ebb..2346ec7 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -215,7 +215,7 @@ test zlib-8.5 {transformation and flushing and fileevents: Bug 3525907} -setup {
set ::res
} -cleanup {
catch {close $r}
-} -result {qwertyuiop MIDDLE asdfghjkl}
+} -result {qwertyuiop MIDDLE asdfghjkl {}}
test zlib-8.6 {transformation and fconfigure} -setup {
set file [makeFile {} test.z]
set fd [open $file wb]