summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/chan.test4
-rw-r--r--tests/cmdAH.test4
-rw-r--r--tests/cmdMZ.test2
-rw-r--r--tests/compile.test12
-rw-r--r--tests/env.test42
-rw-r--r--tests/event.test7
-rw-r--r--tests/fCmd.test126
-rw-r--r--tests/http.test65
-rw-r--r--tests/http11.test183
-rw-r--r--tests/httpPipeline.test26
-rw-r--r--tests/httpd6
-rw-r--r--tests/httpd11.tcl31
-rw-r--r--tests/interp.test2
-rw-r--r--tests/io.test110
-rw-r--r--tests/proc.test7
-rw-r--r--tests/result.test4
-rw-r--r--tests/safe.test8
17 files changed, 557 insertions, 82 deletions
diff --git a/tests/chan.test b/tests/chan.test
index 92846d5..4155c36 100644
--- a/tests/chan.test
+++ b/tests/chan.test
@@ -55,13 +55,13 @@ test chan-4.3 {chan command: [Bug 800753]} -body {
} -returnCodes error -match glob -result {bad value*}
test chan-4.4 {chan command: check valid inValue, no outValue} -body {
chan configure stdout -eofchar [list \x27 {}]
-} -returnCodes ok -result {}
+} -result {}
test chan-4.5 {chan command: check valid inValue, invalid outValue} -body {
chan configure stdout -eofchar [list \x27 \x80]
} -returnCodes error -match glob -result {bad value for -eofchar:*}
test chan-4.6 {chan command: check no inValue, valid outValue} -body {
chan configure stdout -eofchar [list {} \x27]
-} -returnCodes ok -result {} -cleanup {chan configure stdout -eofchar [list {} {}]}
+} -result {} -cleanup {chan configure stdout -eofchar [list {} {}]}
test chan-5.1 {chan command: copy subcommand} -body {
chan copy foo
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index ab1a8e6..a734541 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -355,7 +355,7 @@ test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body {
} -result {wrong # args: should be "file subcommand ?arg ...?"}
test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body {
file x
-} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable}
+} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, tildeexpand, type, volumes, or writable}
test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body {
file exists
} -result {wrong # args: should be "file exists name"}
@@ -1686,7 +1686,7 @@ test cmdAH-29.6.1 {
# Error conditions
test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
file gorp x
-} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable}
+} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, tildeexpand, type, volumes, or writable}
test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body {
file ex x
} -match glob -result {unknown or ambiguous subcommand "ex": must be *}
diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test
index a1cb6c2..a7aa36c 100644
--- a/tests/cmdMZ.test
+++ b/tests/cmdMZ.test
@@ -158,7 +158,7 @@ test cmdMZ-return-2.11 {return option handling} {
} {3 {-code 3 -level 0}}
test cmdMZ-return-2.12 {return option handling} -body {
return -level 0 -code error -options {-code ok}
-} -returnCodes ok -result {}
+} -result {}
test cmdMZ-return-2.13 {return option handling} -body {
return -level 0 -code error -options {-code err}
} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer}
diff --git a/tests/compile.test b/tests/compile.test
index 9959da4..aec1ef1 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -652,26 +652,26 @@ test compile-16.18.$noComp {TclCompileScript: word expansion} -body {
llength [run "list [string repeat {{*}[LongList] } [expr {1<<10}]]"]
} -constraints [linsert $constraints 0 knownBug] -cleanup {
rename LongList {}
-} -returnCodes ok -result [expr {1<<20}]
+} -result [expr {1<<20}]
test compile-16.19.$noComp {TclCompileScript: word expansion} -body {
proc LongList {} {return [lrepeat [expr {1<<11}] x]}
llength [run "list [string repeat {{*}[LongList] } [expr {1<<11}]]"]
} -constraints [linsert $constraints 0 knownBug] -cleanup {
rename LongList {}
-} -returnCodes ok -result [expr {1<<22}]
+} -result [expr {1<<22}]
test compile-16.20.$noComp {TclCompileScript: word expansion} -body {
proc LongList {} {return [lrepeat [expr {1<<12}] x]}
llength [run "list [string repeat {{*}[LongList] } [expr {1<<12}]]"]
} -constraints [linsert $constraints 0 knownBug] -cleanup {
rename LongList {}
-} -returnCodes ok -result [expr {1<<24}]
+} -result [expr {1<<24}]
# This is the one that should cause overflow
test compile-16.21.$noComp {TclCompileScript: word expansion} -body {
proc LongList {} {return [lrepeat [expr {1<<16}] x]}
llength [run "list [string repeat {{*}[LongList] } [expr {1<<16}]]"]
} -constraints [linsert $constraints 0 knownBug] -cleanup {
rename LongList {}
-} -returnCodes ok -result [expr {wide(1)<<32}]
+} -result [expr {wide(1)<<32}]
test compile-16.22.$noComp {
Bug 845412: TclCompileScript: word expansion not mandatory
} -body {
@@ -680,7 +680,7 @@ test compile-16.22.$noComp {
run "ReturnResults [string repeat {x } 260]"
} -constraints $constraints -cleanup {
rename ReturnResults {}
-} -returnCodes ok -result [string trim [string repeat {x } 260]]
+} -result [string trim [string repeat {x } 260]]
test compile-16.23.$noComp {
Bug 1032805: defer parse error until run time
} -constraints $constraints -body {
@@ -692,7 +692,7 @@ test compile-16.23.$noComp {
}
} -cleanup {
namespace delete x
-} -returnCodes ok -result {syntax {}{}}
+} -result {syntax {}{}}
test compile-16.24.$noComp {
Bug 1638414: bad list constant as first expanded term
} -constraints $constraints -body {
diff --git a/tests/env.test b/tests/env.test
index 9eacd5d..dd88431 100644
--- a/tests/env.test
+++ b/tests/env.test
@@ -107,6 +107,7 @@ variable keep {
CommonProgramFiles CommonProgramFiles(x86) ProgramFiles
ProgramFiles(x86) CommonProgramW6432 ProgramW6432
WINECONFIGDIR WINEDATADIR WINEDLLDIR0 WINEHOMEDIR PROCESSOR_ARCHITECTURE
+ USERPROFILE
}
variable printenvScript [makeFile [string map [list @keep@ [list $keep]] {
@@ -411,7 +412,7 @@ test env-7.3 {
return [info exists ::env(test7_3)]
}}
} -cleanup cleanup1 -result 1
-
+
test env-8.0 {
memory usage - valgrind does not report reachable memory
} -body {
@@ -421,6 +422,45 @@ test env-8.0 {
} -result {i'm with dummy}
+test env-9.0 {
+ Initialization of HOME from HOMEDRIVE and HOMEPATH
+} -constraints win -setup {
+ setup1
+ unset -nocomplain ::env(HOME)
+ set ::env(HOMEDRIVE) X:
+ set ::env(HOMEPATH) \\home\\path
+} -cleanup {
+ cleanup1
+} -body {
+ set pipe [open |[list [interpreter]] r+]
+ puts $pipe {puts $::env(HOME); flush stdout; exit}
+ flush $pipe
+ set result [gets $pipe]
+ close $pipe
+ set result
+} -result {X:\home\path}
+
+test env-9.1 {
+ Initialization of HOME from USERPROFILE
+} -constraints win -setup {
+ setup1
+ unset -nocomplain ::env(HOME)
+ unset -nocomplain ::env(HOMEDRIVE)
+ unset -nocomplain ::env(HOMEPATH)
+} -cleanup {
+ cleanup1
+} -body {
+ set pipe [open |[list [interpreter]] r+]
+ puts $pipe {puts $::env(HOME); flush stdout; exit}
+ flush $pipe
+ set result [gets $pipe]
+ close $pipe
+ if {$result ne $::env(USERPROFILE)} {
+ list ERROR $result ne $::env(USERPROFILE)
+ }
+} -result {}
+
+
# cleanup
rename getenv {}
diff --git a/tests/event.test b/tests/event.test
index 3f9735a..16cbc24 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -509,12 +509,9 @@ test event-10.1 {Tcl_Exit procedure} {stdio} {
[lindex $::errorCode 2]
} {1 {child process exited abnormally} CHILDSTATUS 3}
-test event-11.1 {Tcl_VwaitCmd procedure} -returnCodes error -body {
+test event-11.1 {Tcl_VwaitCmd procedure} -body {
vwait
-} -result {wrong # args: should be "vwait name"}
-test event-11.2 {Tcl_VwaitCmd procedure} -returnCodes error -body {
- vwait a b
-} -result {wrong # args: should be "vwait name"}
+} -result {}
test event-11.3 {Tcl_VwaitCmd procedure} -setup {
catch {unset x}
} -body {
diff --git a/tests/fCmd.test b/tests/fCmd.test
index 13f3720..73118f4 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -2556,6 +2556,132 @@ test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win notInCIenv} -
}
return $r
} -result {exists 1 readable 0 stat 0 {}}
+
+test fCmd-31.1 {file home} -body {
+ file home
+} -result [file join $::env(HOME)]
+test fCmd-31.2 {file home - obeys env} -setup {
+ set ::env(HOME) $::env(HOME)/xxx
+} -cleanup {
+ set ::env(HOME) [file dirname $::env(HOME)]
+} -body {
+ file home
+} -result [file join $::env(HOME) xxx]
+test fCmd-31.3 {file home - \ -> /} -constraints win -setup {
+ set saved $::env(HOME)
+ set ::env(HOME) C:\\backslash\\path
+} -cleanup {
+ set ::env(HOME) $saved
+} -body {
+ file home
+} -result C:/backslash/path
+test fCmd-31.4 {file home - error} -setup {
+ set saved $::env(HOME)
+ unset ::env(HOME)
+} -cleanup {
+ set ::env(HOME) $saved
+} -body {
+ file home
+} -returnCodes error -result {couldn't find HOME environment variable to expand path}
+test fCmd-31.5 {
+ file home - relative path. Following 8.x ~ expansion behavior, relative
+ paths are not made absolute
+} -setup {
+ set saved $::env(HOME)
+ set ::env(HOME) relative/path
+} -cleanup {
+ set ::env(HOME) $saved
+} -body {
+ file home
+} -result relative/path
+test fCmd-31.6 {file home USER} -body {
+ # Note - as in 8.x this form does NOT necessarily give same result as
+ # env(HOME) even when user is current user. Assume result contains user
+ # name, else not sure how to check
+ file home $::tcl_platform(user)
+} -match glob -result "*$::tcl_platform(user)*"
+test fCmd-31.7 {file home UNKNOWNUSER} -body {
+ file home nosuchuser
+} -returnCodes error -result {user "nosuchuser" doesn't exist}
+test fCmd-31.8 {file home extra arg} -body {
+ file home $::tcl_platform(user) arg
+} -returnCodes error -result {wrong # args: should be "file home ?user?"}
+
+test fCmd-32.1 {file tildeexpand ~} -body {
+ file tildeexpand ~
+} -result [file join $::env(HOME)]
+test fCmd-32.2 {file tildeexpand ~ - obeys env} -setup {
+ set ::env(HOME) $::env(HOME)/xxx
+} -cleanup {
+ set ::env(HOME) [file dirname $::env(HOME)]
+} -body {
+ file tildeexpand ~
+} -result [file join $::env(HOME) xxx]
+test fCmd-32.3 {file tildeexpand ~ - error} -setup {
+ set saved $::env(HOME)
+ unset ::env(HOME)
+} -cleanup {
+ set ::env(HOME) $saved
+} -body {
+ file tildeexpand ~
+} -returnCodes error -result {couldn't find HOME environment variable to expand path}
+test fCmd-32.4 {
+ file tildeexpand ~ - relative path. Following 8.x ~ expansion behavior, relative
+ paths are not made absolute
+} -setup {
+ set saved $::env(HOME)
+ set ::env(HOME) relative/path
+} -cleanup {
+ set ::env(HOME) $saved
+} -body {
+ file tildeexpand ~
+} -result relative/path
+test fCmd-32.5 {file tildeexpand ~USER} -body {
+ # Note - as in 8.x this form does NOT necessarily give same result as
+ # env(HOME) even when user is current user. Assume result contains user
+ # name, else not sure how to check
+ file tildeexpand ~$::tcl_platform(user)
+} -match glob -result "*$::tcl_platform(user)*"
+test fCmd-32.6 {file tildeexpand ~UNKNOWNUSER} -body {
+ file tildeexpand ~nosuchuser
+} -returnCodes error -result {user "nosuchuser" doesn't exist}
+test fCmd-32.7 {file tildeexpand ~extra arg} -body {
+ file tildeexpand ~ arg
+} -returnCodes error -result {wrong # args: should be "file tildeexpand path"}
+test fCmd-32.8 {file tildeexpand ~/path} -body {
+ file tildeexpand ~/foo
+} -result [file join $::env(HOME)/foo]
+test fCmd-32.9 {file tildeexpand ~USER/bar} -body {
+ # Note - as in 8.x this form does NOT necessarily give same result as
+ # env(HOME) even when user is current user. Assume result contains user
+ # name, else not sure how to check
+ file tildeexpand ~$::tcl_platform(user)/bar
+} -match glob -result "*$::tcl_platform(user)*/bar"
+test fCmd-32.10 {file tildeexpand ~UNKNOWNUSER} -body {
+ file tildeexpand ~nosuchuser/foo
+} -returnCodes error -result {user "nosuchuser" doesn't exist}
+test fCmd-32.11 {file tildeexpand /~/path} -body {
+ file tildeexpand /~/foo
+} -result /~/foo
+test fCmd-32.12 {file tildeexpand /~user/path} -body {
+ file tildeexpand /~$::tcl_platform(user)/foo
+} -result /~$::tcl_platform(user)/foo
+test fCmd-32.13 {file tildeexpand ./~} -body {
+ file tildeexpand ./~
+} -result ./~
+test fCmd-32.14 {file tildeexpand relative/path} -body {
+ file tildeexpand relative/path
+} -result relative/path
+test fCmd-32.15 {file tildeexpand ~\\path} -body {
+ file tildeexpand ~\\foo
+} -constraints win -result [file join $::env(HOME)/foo]
+test fCmd-32.16 {file tildeexpand ~USER\\bar} -body {
+ # Note - as in 8.x this form does NOT necessarily give same result as
+ # env(HOME) even when user is current user. Assume result contains user
+ # name, else not sure how to check
+ file tildeexpand ~$::tcl_platform(user)\\bar
+} -constraints win -match glob -result "*$::tcl_platform(user)*/bar"
+
# cleanup
cleanup
diff --git a/tests/http.test b/tests/http.test
index a6f1ce6..e88210a 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -17,20 +17,7 @@ if {"::tcltest" ni [namespace children]} {
}
package require tcltests
-if {[catch {package require http 2} version]} {
- if {[info exists http2]} {
- catch {puts "Cannot load http 2.* package"}
- return
- } else {
- catch {puts "Running http 2.* tests in child interp"}
- set interp [interp create http2]
- $interp eval [list set http2 "running"]
- $interp eval [list set argv $argv]
- $interp eval [list source [info script]]
- interp delete $interp
- return
- }
-}
+package require http 2.10
proc bgerror {args} {
global errorInfo
@@ -78,11 +65,31 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} {
return
}
}
+
+if {![info exists ThreadLevel]} {
+ if {[catch {package require Thread}] == 0} {
+ set ValueRange {0 1 2}
+ } else {
+ set ValueRange {0 1}
+ }
+
+ # For each value of ThreadLevel, source this file recursively in the
+ # same interpreter.
+ foreach ThreadLevel $ValueRange {
+ source [info script]
+ }
+ catch {unset ThreadLevel}
+ catch {unset ValueRange}
+ return
+}
+
+catch {puts "==== Test with ThreadLevel $ThreadLevel ===="}
+http::config -threadlevel $ThreadLevel
test http-1.1 {http::config} {
http::config -useragent UserAgent
http::config
-} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1]
+} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -threadlevel $ThreadLevel -urlencoding utf-8 -useragent UserAgent -zip 1]
test http-1.2 {http::config} {
http::config -proxyfilter
} http::ProxyRequired
@@ -97,10 +104,10 @@ test http-1.4 {http::config} {
set x [http::config]
http::config {*}$savedconf
set x
-} {-accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1}
+} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -threadlevel $ThreadLevel -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1]
test http-1.5 {http::config} -returnCodes error -body {
http::config -proxyhost {} -junk 8080
-} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip}
+} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -threadlevel, -urlencoding, -useragent, -zip}
test http-1.6 {http::config} -setup {
set oldenc [http::config -urlencoding]
} -body {
@@ -138,10 +145,12 @@ test http-2.8 {http::CharsetToEncoding} {
test http-3.1 {http::geturl} -returnCodes error -body {
http::geturl -bogus flag
-} -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate}
+} -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -guesstype, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate}
+
test http-3.2 {http::geturl} -returnCodes error -body {
http::geturl http:junk
} -result {Unsupported URL: http:junk}
+
set url //${::HOST}:$port
set badurl //${::HOST}:[expr {$port+1}]
test http-3.3 {http::geturl} -body {
@@ -153,6 +162,7 @@ test http-3.3 {http::geturl} -body {
<h1>Hello, World!</h1>
<h2>GET /</h2>
</body></html>"
+
set tail /a/b/c
set url //${::HOST}:$port/a/b/c
set fullurl HTTP://user:pass@${::HOST}:$port/a/b/c
@@ -162,6 +172,7 @@ set posturl //${::HOST}:$port/post
set badposturl //${::HOST}:$port/droppost
set authorityurl //${::HOST}:$port
set ipv6url http://\[::1\]:$port/
+
test http-3.4 {http::geturl} -body {
set token [http::geturl $url]
http::data $token
@@ -379,7 +390,7 @@ test http-3.25 {http::meta} -setup {
} -cleanup {
http::cleanup $token
unset -nocomplain m token
-} -result {Content-Length Content-Type Date}
+} -result {content-length content-type date}
test http-3.26 {http::meta} -setup {
unset -nocomplain m token
} -body {
@@ -389,7 +400,7 @@ test http-3.26 {http::meta} -setup {
} -cleanup {
http::cleanup $token
unset -nocomplain m token
-} -result {Content-Length Content-Type Date X-Check}
+} -result {content-length content-type date x-check}
test http-3.27 {http::geturl: -headers override -type} -body {
set token [http::geturl $url/headers -type "text/plain" -query dummy \
-headers [list "Content-Type" "text/plain;charset=utf-8"]]
@@ -474,7 +485,7 @@ test http-4.1 {http::Event} -body {
set token [http::geturl $url -keepalive 0]
upvar #0 $token data
array set meta $data(meta)
- expr {($data(totalsize) == $meta(Content-Length))}
+ expr {($data(totalsize) == $meta(content-length))}
} -cleanup {
http::cleanup $token
} -result 1
@@ -482,7 +493,7 @@ test http-4.2 {http::Event} -body {
set token [http::geturl $url]
upvar #0 $token data
array set meta $data(meta)
- string compare $data(type) [string trim $meta(Content-Type)]
+ string compare $data(type) [string trim $meta(content-type)]
} -cleanup {
http::cleanup $token
} -result 0
@@ -572,6 +583,7 @@ test http-4.10 {http::Event} -body {
} -cleanup {
http::cleanup $token
} -result {111}
+
# Timeout cases
# Short timeout to working server (the test server). This lets us try a
# reset during the connection.
@@ -582,6 +594,7 @@ test http-4.11 {http::Event} -body {
} -cleanup {
http::cleanup $token
} -result {reset}
+
# Longer timeout with reset.
test http-4.12 {http::Event} -body {
set token [http::geturl $url/?timeout=10 -keepalive 0 -command \#]
@@ -590,6 +603,7 @@ test http-4.12 {http::Event} -body {
} -cleanup {
http::cleanup $token
} -result {reset}
+
# Medium timeout to working server that waits even longer. The timeout
# hits while waiting for a reply.
test http-4.13 {http::Event} -body {
@@ -599,6 +613,7 @@ test http-4.13 {http::Event} -body {
} -cleanup {
http::cleanup $token
} -result {timeout}
+
# Longer timeout to good host, bad port, gets an error after the
# connection "completes" but the socket is bad.
test http-4.14 {http::Event} -body {
@@ -611,17 +626,19 @@ test http-4.14 {http::Event} -body {
} -cleanup {
catch {http::cleanup $token}
} -result {connect failed connection refused}
+
# Bogus host
test http-4.15 {http::Event} -body {
# This test may fail if you use a proxy server. That is to be
# expected and is not a problem with Tcl.
set token [http::geturl //not_a_host.tcl.tk -timeout 3000 -command \#]
http::wait $token
- http::status $token
+ set result "[http::status $token] -- [lindex [http::error $token] 0]"
# error codes vary among platforms.
} -cleanup {
catch {http::cleanup $token}
-} -returnCodes 1 -match glob -result "couldn't open socket*"
+} -match glob -result "error -- couldn't open socket*"
+
test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup {
proc list-difference {l1 l2} {
lmap item $l2 {if {$item in $l1} continue; set item}
diff --git a/tests/http11.test b/tests/http11.test
index 4f6fb92..71ef4c7 100644
--- a/tests/http11.test
+++ b/tests/http11.test
@@ -12,7 +12,7 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
-package require http 2.9
+package require http 2.10
# start the server
variable httpd_output
@@ -51,15 +51,11 @@ proc halt_httpd {} {
}
proc meta {tok {key ""}} {
- set meta [http::meta $tok]
- if {$key ne ""} {
- if {[dict exists $meta $key]} {
- return [dict get $meta $key]
- } else {
- return ""
- }
+ if {$key eq ""} {
+ return [http::meta $tok]
+ } else {
+ return [http::metaValue $tok $key]
}
- return $meta
}
proc state {tok {key ""}} {
@@ -87,6 +83,28 @@ proc check_crc {tok args} {
}
makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 4192]\n</body></html>" testdoc.html
+
+makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 5000]\n</body></html>" largedoc.html
+
+if {![info exists ThreadLevel]} {
+ if {[catch {package require Thread}] == 0} {
+ set ValueRange {0 1 2}
+ } else {
+ set ValueRange {0 1}
+ }
+
+ # For each value of ThreadLevel, source this file recursively in the
+ # same interpreter.
+ foreach ThreadLevel $ValueRange {
+ source [info script]
+ }
+ catch {unset ThreadLevel}
+ catch {unset ValueRange}
+ return
+}
+
+catch {puts "==== Test with ThreadLevel $ThreadLevel ===="}
+http::config -threadlevel $ThreadLevel
# -------------------------------------------------------------------------
@@ -108,11 +126,12 @@ test http11-1.1 "normal,gzip,non-chunked" -setup {
-timeout 10000 -headers {accept-encoding gzip}]
http::wait $tok
list [http::status $tok] [http::code $tok] [check_crc $tok] \
- [meta $tok content-encoding] [meta $tok transfer-encoding]
+ [meta $tok content-encoding] [meta $tok transfer-encoding] \
+ [http::meta $tok content-encoding] [http::meta $tok transfer-encoding]
} -cleanup {
http::cleanup $tok
halt_httpd
-} -result {ok {HTTP/1.1 200 OK} ok gzip {}}
+} -result {ok {HTTP/1.1 200 OK} ok gzip {} {content-encoding gzip} {}}
test http11-1.2 "normal,deflated,non-chunked" -setup {
variable httpd [create_httpd]
@@ -127,7 +146,22 @@ test http11-1.2 "normal,deflated,non-chunked" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok deflate {}}
-test http11-1.3 "normal,compressed,non-chunked" -setup {
+test http11-1.2.1 "normal,deflated,non-chunked,msdeflate" -setup {
+ variable httpd [create_httpd]
+} -body {
+ set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&msdeflate=1 \
+ -timeout 10000 -headers {accept-encoding deflate}]
+ http::wait $tok
+ list [http::status $tok] [http::code $tok] [check_crc $tok] \
+ [meta $tok content-encoding] [meta $tok transfer-encoding]
+} -cleanup {
+ http::cleanup $tok
+ halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok deflate {}}
+
+test http11-1.3 "normal,compressed,non-chunked" -constraints badCompress -setup {
+ # The Tcl "compress" algorithm appears to be incorrect and has been removed.
+ # Bug [a13b9d0ce1].
variable httpd [create_httpd]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
@@ -173,11 +207,12 @@ test http11-1.6 "normal, specify 1.1 " -setup {
-protocol 1.1 -timeout 10000]
http::wait $tok
list [http::status $tok] [http::code $tok] [check_crc $tok] \
- [meta $tok connection] [meta $tok transfer-encoding]
+ [meta $tok connection] [meta $tok transfer-encoding] \
+ [http::meta $tok connection] [http::meta $tok transfer-encoding]
} -cleanup {
http::cleanup $tok
halt_httpd
-} -result {ok {HTTP/1.1 200 OK} ok close chunked}
+} -result {ok {HTTP/1.1 200 OK} ok close chunked {connection close} {transfer-encoding chunked}}
test http11-1.7 "normal, 1.1 and keepalive " -setup {
variable httpd [create_httpd]
@@ -231,7 +266,22 @@ test http11-1.10 "normal,deflate,chunked" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok deflate chunked}
-test http11-1.11 "normal,compress,chunked" -setup {
+test http11-1.10.1 "normal,deflate,chunked,msdeflate" -setup {
+ variable httpd [create_httpd]
+} -body {
+ set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \
+ -timeout 10000 -headers {accept-encoding deflate}]
+ http::wait $tok
+ list [http::status $tok] [http::code $tok] [check_crc $tok] \
+ [meta $tok content-encoding] [meta $tok transfer-encoding]
+} -cleanup {
+ http::cleanup $tok
+ halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok deflate chunked}
+
+test http11-1.11 "normal,compress,chunked" -constraints badCompress -setup {
+ # The Tcl "compress" algorithm appears to be incorrect and has been removed.
+ # Bug [a13b9d0ce1].
variable httpd [create_httpd]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
@@ -323,15 +373,40 @@ test http11-2.1 "-channel, encoding gzip" -setup {
http::wait $tok
seek $chan 0
set data [read $chan]
+ set diff [expr {[file size testdoc.html] - [file size testfile.tmp]}]
list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
[meta $tok connection] [meta $tok content-encoding]\
- [meta $tok transfer-encoding]
+ [meta $tok transfer-encoding] -- $diff bytes lost
} -cleanup {
http::cleanup $tok
close $chan
removeFile testfile.tmp
halt_httpd
-} -result {ok {HTTP/1.1 200 OK} ok close gzip chunked}
+} -result {ok {HTTP/1.1 200 OK} ok close gzip chunked -- 0 bytes lost}
+
+# Cf. Bug [3610253] "CopyChunk does not drain decompressor(s)"
+# This test failed before the bugfix.
+# The pass/fail depended on file size.
+test http11-2.1.1 "-channel, encoding gzip" -setup {
+ variable httpd [create_httpd]
+ set chan [open [makeFile {} testfile.tmp] wb+]
+ set fileName largedoc.html
+} -body {
+ set tok [http::geturl http://localhost:$httpd_port/$fileName \
+ -timeout 5000 -channel $chan -headers {accept-encoding gzip}]
+ http::wait $tok
+ seek $chan 0
+ set data [read $chan]
+ set diff [expr {[file size $fileName] - [file size testfile.tmp]}]
+ list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
+ [meta $tok connection] [meta $tok content-encoding]\
+ [meta $tok transfer-encoding] -- $diff bytes lost
+} -cleanup {
+ http::cleanup $tok
+ close $chan
+ removeFile testfile.tmp
+ halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok close gzip chunked -- 0 bytes lost}
test http11-2.2 "-channel, encoding deflate" -setup {
variable httpd [create_httpd]
@@ -352,7 +427,28 @@ test http11-2.2 "-channel, encoding deflate" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok close deflate chunked}
-test http11-2.3 "-channel,encoding compress" -setup {
+test http11-2.2.1 "-channel, encoding deflate,msdeflate" -setup {
+ variable httpd [create_httpd]
+ set chan [open [makeFile {} testfile.tmp] wb+]
+} -body {
+ set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \
+ -timeout 5000 -channel $chan -headers {accept-encoding deflate}]
+ http::wait $tok
+ seek $chan 0
+ set data [read $chan]
+ list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
+ [meta $tok connection] [meta $tok content-encoding]\
+ [meta $tok transfer-encoding]
+} -cleanup {
+ http::cleanup $tok
+ close $chan
+ removeFile testfile.tmp
+ halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok close deflate chunked}
+
+test http11-2.3 "-channel,encoding compress" -constraints badCompress -setup {
+ # The Tcl "compress" algorithm appears to be incorrect and has been removed.
+ # Bug [a13b9d0ce1].
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
@@ -504,7 +600,32 @@ test http11-2.7 "-channel,encoding deflate,non-chunked" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok close deflate {} 0}
-test http11-2.8 "-channel,encoding compress,non-chunked" -setup {
+test http11-2.7.1 "-channel,encoding deflate,non-chunked,msdeflate" -constraints knownBug -setup {
+ # Test fails because a -channel can only try one un-deflate algorithm, and the
+ # compliant "decompress" is tried, not the non-compliant "inflate" of
+ # the MS browser implementation.
+ variable httpd [create_httpd]
+ set chan [open [makeFile {} testfile.tmp] wb+]
+} -body {
+ set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&msdeflate=1 \
+ -timeout 5000 -channel $chan -headers {accept-encoding deflate}]
+ http::wait $tok
+ seek $chan 0
+ set data [read $chan]
+ list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
+ [meta $tok connection] [meta $tok content-encoding]\
+ [meta $tok transfer-encoding]\
+ [expr {[file size testdoc.html]-[file size testfile.tmp]}]
+} -cleanup {
+ http::cleanup $tok
+ close $chan
+ removeFile testfile.tmp
+ halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok close deflate {} 0}
+
+test http11-2.8 "-channel,encoding compress,non-chunked" -constraints badCompress -setup {
+ # The Tcl "compress" algorithm appears to be incorrect and has been removed.
+ # Bug [a13b9d0ce1].
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
@@ -565,6 +686,27 @@ test http11-2.10 "-channel,deflate,keepalive" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok {} deflate chunked 0}
+test http11-2.10.1 "-channel,deflate,keepalive,msdeflate" -setup {
+ variable httpd [create_httpd]
+ set chan [open [makeFile {} testfile.tmp] wb+]
+} -body {
+ set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \
+ -timeout 5000 -channel $chan -keepalive 1 \
+ -headers {accept-encoding deflate}]
+ http::wait $tok
+ seek $chan 0
+ set data [read $chan]
+ list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
+ [meta $tok connection] [meta $tok content-encoding]\
+ [meta $tok transfer-encoding]\
+ [expr {[file size testdoc.html]-[file size testfile.tmp]}]
+} -cleanup {
+ http::cleanup $tok
+ close $chan
+ removeFile testfile.tmp
+ halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok {} deflate chunked 0}
+
test http11-2.11 "-channel,identity,keepalive" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
@@ -603,7 +745,7 @@ test http11-2.12 "-channel,negotiate,keepalive" -setup {
close $chan
removeFile testfile.tmp
halt_httpd
-} -result {ok {HTTP/1.1 200 OK} ok {} gzip chunked gzip,deflate,compress 0}
+} -result {ok {HTTP/1.1 200 OK} ok {} gzip chunked gzip,deflate 0}
# -------------------------------------------------------------------------
@@ -918,6 +1060,7 @@ foreach p {create_httpd httpd_read halt_httpd meta check_crc} {
if {[llength [info proc $p]]} {rename $p {}}
}
removeFile testdoc.html
+removeFile largedoc.html
unset -nocomplain httpd_port httpd p
::tcltest::cleanupTests
diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test
index 4e55a10..161519f 100644
--- a/tests/httpPipeline.test
+++ b/tests/httpPipeline.test
@@ -13,7 +13,31 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
-package require http 2.9
+package require http 2.10
+
+# ------------------------------------------------------------------------------
+# (0) Socket Creation in Thread, which triples the number of tests.
+# ------------------------------------------------------------------------------
+
+if {![info exists ThreadLevel]} {
+ if {[catch {package require Thread}] == 0} {
+ set ValueRange {0 1 2}
+ } else {
+ set ValueRange {0 1}
+ }
+
+ # For each value of ThreadLevel, source this file recursively in the
+ # same interpreter.
+ foreach ThreadLevel $ValueRange {
+ source [info script]
+ }
+ catch {unset ThreadLevel}
+ catch {unset ValueRange}
+ return
+}
+
+catch {puts "==== Test with ThreadLevel $ThreadLevel ===="}
+http::config -threadlevel $ThreadLevel
set sourcedir [file normalize [file dirname [info script]]]
source [file join $sourcedir httpTest.tcl]
diff --git a/tests/httpd b/tests/httpd
index 43e9372..a7b42a1 100644
--- a/tests/httpd
+++ b/tests/httpd
@@ -50,7 +50,7 @@ proc httpdAccept {newsock ipaddr port} {
fconfigure $newsock -blocking 0 -translation {auto crlf}
httpd_log $newsock Connect $ipaddr $port
set data(ipaddr) $ipaddr
- after 50 [list fileevent $newsock readable [list httpdRead $newsock]]
+ fileevent $newsock readable [list httpdRead $newsock]
}
# read data from a client request
@@ -69,6 +69,10 @@ proc httpdRead { sock } {
-> data(proto) data(url) data(query) data(httpversion)]} {
set data(state) mime
httpd_log $sock Query $line
+ if {[regexp {(?:^|[\?&])delay=([^&]+)} $data(query) {} val]} {
+ fileevent $sock readable {}
+ after $val [list fileevent $sock readable [list httpdRead $sock]]
+ }
} else {
httpdError $sock 400
httpd_log $sock Error "bad first line:$line"
diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl
index d0624f8..55b52fd 100644
--- a/tests/httpd11.tcl
+++ b/tests/httpd11.tcl
@@ -46,7 +46,7 @@ proc get-chunks {data {compression gzip}} {
}
set data ""
- set chunker [make-chunk-generator $data 512]
+ set chunker [make-chunk-generator $data 671]
while {[string length [set chunk [$chunker]]]} {
append data $chunk
}
@@ -60,7 +60,7 @@ proc blow-chunks {data {ochan stdout} {compression gzip}} {
compress { set data [zlib compress $data] }
}
- set chunker [make-chunk-generator $data 512]
+ set chunker [make-chunk-generator $data 671]
while {[string length [set chunk [$chunker]]]} {
puts -nonewline $ochan $chunk
}
@@ -160,6 +160,12 @@ proc Service {chan addr port} {
if {$protocol eq "HTTP/1.1"} {
foreach enc [split [dict get? $meta accept-encoding] ,] {
set enc [string trim $enc]
+ # The current implementation of "compress" appears to be
+ # incorrect (bug [a13b9d0ce1]). Keep it here for
+ # experimentation only. The tests that use it have the
+ # constraint "badCompress". The client code in http has
+ # been removed, but can be restored from comments if
+ # experimentation is desired.
if {$enc in {deflate gzip compress}} {
set encoding $enc
break
@@ -171,6 +177,7 @@ proc Service {chan addr port} {
}
set nosendclose 0
+ set msdeflate 0
foreach pair [split $query &] {
if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""}
switch -exact -- $key {
@@ -178,6 +185,7 @@ proc Service {chan addr port} {
close {set close 1 ; set transfer 0}
transfer {set transfer $val}
content-type {set type $val}
+ msdeflate {set msdeflate $val}
}
}
if {$protocol eq "HTTP/1.1"} {
@@ -211,10 +219,23 @@ proc Service {chan addr port} {
flush $chan
chan configure $chan -buffering full -translation binary
+ if {$encoding eq {deflate}} {
+ # When http.tcl uses the correct decoder (bug [a13b9d0ce1]) for
+ # "accept-encoding deflate", i.e. "zlib decompress", this choice of
+ # encoding2 allows the tests to pass. It appears to do "deflate"
+ # correctly, but this has not been verified with a non-Tcl client.
+ set encoding2 compress
+ } else {
+ set encoding2 $encoding
+ }
if {$transfer eq "chunked"} {
- blow-chunks $data $chan $encoding
- } elseif {$encoding ne "identity"} {
- puts -nonewline $chan [zlib $encoding $data]
+ blow-chunks $data $chan $encoding2
+ } elseif {$encoding2 ne "identity" && $msdeflate eq {1}} {
+ puts -nonewline $chan [string range [zlib $encoding2 $data] 2 end-4]
+ # Used in some tests of "deflate" to produce the non-RFC-compliant
+ # Microsoft version of "deflate".
+ } elseif {$encoding2 ne "identity"} {
+ puts -nonewline $chan [zlib $encoding2 $data]
} else {
puts -nonewline $chan $data
}
diff --git a/tests/interp.test b/tests/interp.test
index 385d3e2..fa263e2 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -1640,7 +1640,7 @@ test interp-20.50.1 {Bug 2486550} -setup {
} -cleanup {
unset -nocomplain m 0
interp delete child
-} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?"
+} -result {wrong # args: should be "coroutine name cmd ?arg ...?"
while executing
"coroutine"
invoked from within
diff --git a/tests/io.test b/tests/io.test
index 6314ace..32c4b99 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -13,12 +13,12 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {"::tcltest" ni [namespace children]} {
- package require tcltest 2.5
-}
-
namespace eval ::tcl::test::io {
- namespace import ::tcltest::*
+
+ if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+ namespace import -force ::tcltest::*
+ }
variable umaskValue
variable path
@@ -8566,7 +8566,7 @@ test io-60.1 {writing illegal utf sequences} {fileevent testbytestring} {
set out [open $path(script) w]
puts $out "catch {load $::tcltestlib Tcltest}"
puts $out {
- puts [testbytestring \xE2]
+ puts ABC[testbytestring \xE2]
exit 1
}
proc readit {pipe} {
@@ -8590,7 +8590,7 @@ test io-60.1 {writing illegal utf sequences} {fileevent testbytestring} {
# cut of the remainder of the error stack, especially the filename
set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]]
list $x $result
-} {1 {gets {} catch {error writing "stdout": illegal byte sequence}}}
+} {1 {gets ABC catch {error writing "stdout": illegal byte sequence}}}
test io-61.1 {Reset eof state after changing the eof char} -setup {
set datafile [makeFile {} eofchar]
@@ -8952,6 +8952,102 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup {
removeFile io-74.1
} -returnCodes error -match glob -result {can not find channel named "*"}
+# The following tests 75.1 to 75.5 exercise strict or tolerant channel
+# encoding.
+# TCL 8.7 only offers tolerant channel encoding, what is tested here.
+test io-75.1 {multibyte encoding error read results in raw bytes} -constraints deprecated -setup {
+ set fn [makeFile {} io-75.1]
+ set f [open $fn w+]
+ fconfigure $f -encoding binary
+ # In UTF-8, a byte 0xCx starts a multibyte sequence and must be followed
+ # by a byte > 0x7F. This is violated to get an invalid sequence.
+ puts -nonewline $f "A\xC0\x40"
+ flush $f
+ seek $f 0
+ fconfigure $f -encoding utf-8 -buffering none
+} -body {
+ set d [read $f]
+ binary scan $d H* hd
+ set hd
+} -cleanup {
+ close $f
+ removeFile io-75.1
+} -result "41c040"
+
+test io-75.2 {unrepresentable character write passes and is replaced by ?} -constraints deprecated -setup {
+ set fn [makeFile {} io-75.2]
+ set f [open $fn w+]
+ fconfigure $f -encoding iso8859-1
+} -body {
+ puts -nonewline $f "A\u2022"
+ flush $f
+ seek $f 0
+ read $f
+} -cleanup {
+ close $f
+ removeFile io-75.2
+} -result "A?"
+
+# Incomplete sequence test.
+# This error may IMHO only be detected with the close.
+# But the read already returns the incomplete sequence.
+test io-75.3 {incomplete multibyte encoding read is ignored} -setup {
+ set fn [makeFile {} io-75.3]
+ set f [open $fn w+]
+ fconfigure $f -encoding binary
+ puts -nonewline $f "A\xC0"
+ flush $f
+ seek $f 0
+ fconfigure $f -encoding utf-8 -buffering none
+} -body {
+ set d [read $f]
+ close $f
+ binary scan $d H* hd
+ set hd
+} -cleanup {
+ removeFile io-75.3
+} -result "41c0"
+
+# As utf-8 has a special treatment in multi-byte decoding, also test another
+# one.
+test io-75.4 {shiftjis encoding error read results in raw bytes} -setup {
+ set fn [makeFile {} io-75.4]
+ set f [open $fn w+]
+ fconfigure $f -encoding binary
+ # In shiftjis, \x81 starts a two-byte sequence.
+ # But 2nd byte \xFF is not allowed
+ puts -nonewline $f "A\x81\xFFA"
+ flush $f
+ seek $f 0
+ fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf
+} -constraints deprecated -body {
+ set d [read $f]
+ binary scan $d H* hd
+ set hd
+} -cleanup {
+ close $f
+ removeFile io-75.4
+} -result "4181ff41"
+
+test io-75.5 {incomplete shiftjis encoding read is ignored} -setup {
+ set fn [makeFile {} io-75.5]
+ set f [open $fn w+]
+ fconfigure $f -encoding binary
+ # \x81 announces a two byte sequence.
+ puts -nonewline $f "A\x81"
+ flush $f
+ seek $f 0
+ fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf
+} -body {
+ set d [read $f]
+ close $f
+ binary scan $d H* hd
+ set hd
+} -cleanup {
+ removeFile io-75.5
+} -result "4181"
+
+
# ### ### ### ######### ######### #########
# cleanup
diff --git a/tests/proc.test b/tests/proc.test
index b87af57..118dca1 100644
--- a/tests/proc.test
+++ b/tests/proc.test
@@ -412,6 +412,13 @@ test proc-7.5 {[631b4c45df] Crash in argument processing} {
unset -nocomplain val
} {}
+test proc-7.6 {[51d5f22997] Crash in argument processing} -cleanup {
+ rename foo {}
+} -body {
+ proc foo {{x {}} {y {}} args} {}
+ foo
+} -result {}
+
# cleanup
catch {rename p ""}
diff --git a/tests/result.test b/tests/result.test
index 845c26e..5ae29b2 100644
--- a/tests/result.test
+++ b/tests/result.test
@@ -109,14 +109,14 @@ test result-6.0 {Bug 1209759} -constraints testreturn -body {
# Might panic if bug is not fixed.
proc foo {} {testreturn}
foo
-} -returnCodes ok -result {}
+} -result {}
test result-6.1 {Bug 1209759} -constraints testreturn -body {
# Might panic if bug is not fixed.
proc foo {} {catch {return -level 2}; testreturn}
foo
} -cleanup {
rename foo {}
-} -returnCodes ok -result {}
+} -result {}
test result-6.2 {Bug 1649062} -setup {
proc foo {} {
if {[catch {
diff --git a/tests/safe.test b/tests/safe.test
index 1853cfc..044e96c 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -1376,7 +1376,7 @@ test safe-10.1.1 {testing statics loading} -constraints tcl::test -setup {
} -body {
catch {interp eval $i {load {} Safepfx1}} m o
dict get $o -errorinfo
-} -returnCodes ok -cleanup {
+} -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure
@@ -1407,7 +1407,7 @@ test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints t
set i [safe::interpCreate -nestedloadok]
catch {interp eval $i {interp create x; load {} Safepfx1 x}} m o
dict get $o -errorinfo
-} -returnCodes ok -cleanup {
+} -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure
@@ -1479,7 +1479,7 @@ test safe-11.7.1 {testing safe encoding} -setup {
} -body {
catch {interp eval $i encoding convertfrom} m o
dict get $o -errorinfo
-} -returnCodes ok -match glob -cleanup {
+} -match glob -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"
@@ -1501,7 +1501,7 @@ test safe-11.8.1 {testing safe encoding} -setup {
} -body {
catch {interp eval $i encoding convertto} m o
dict get $o -errorinfo
-} -returnCodes ok -match glob -cleanup {
+} -match glob -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"
generated by cgit v0.12 at 2024-10-22 18:00:32 (GMT)