summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/all.tcl1
-rw-r--r--tests/dict.test8
-rw-r--r--tests/encoding.test8
-rw-r--r--tests/fCmd.test123
-rw-r--r--tests/fileName.test6
-rw-r--r--tests/fileSystem.test2
-rw-r--r--tests/http.test7
-rw-r--r--tests/io.test28
-rw-r--r--tests/ioCmd.test117
-rw-r--r--tests/msgcat.test4
-rw-r--r--tests/oo.test110
-rw-r--r--tests/platform.test10
-rw-r--r--tests/proc.test9
-rw-r--r--tests/registry.test6
-rw-r--r--tests/safe.test218
-rw-r--r--tests/socket.test24
-rw-r--r--tests/switch.test22
-rw-r--r--tests/winDde.test258
-rw-r--r--tests/zlib.test50
19 files changed, 794 insertions, 217 deletions
diff --git a/tests/all.tcl b/tests/all.tcl
index b436fbe..05d3024 100644
--- a/tests/all.tcl
+++ b/tests/all.tcl
@@ -10,6 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+package prefer latest
package require Tcl 8.5
package require tcltest 2.2
namespace import tcltest::*
diff --git a/tests/dict.test b/tests/dict.test
index 5277cf6..77bacf6 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -1475,7 +1475,7 @@ proc linenumber {} {
dict get [info frame -1] line
}
test dict-23.1 {dict compilation crash: Bug 3487626} {
- apply {n {
+ apply {{} {apply {n {
set e {}
set k {}
dict for {a b} {c {d {e {f g}}}} {
@@ -1487,14 +1487,14 @@ test dict-23.1 {dict compilation crash: Bug 3487626} {
}
}
}
- }} [linenumber]
+ }} [linenumber]}}
} 5
test dict-23.2 {dict compilation crash: Bug 3487626} knownBug {
# Something isn't quite right in line number and continuation line
# tracking; at time of writing, this test produces 7, not 5, which
# indicates that the extra newlines in the non-script argument are
# confusing things.
- apply {n {
+ apply {{} {apply {n {
set e {}
set k {}
dict for {a {
@@ -1518,7 +1518,7 @@ j
}
}
}
- }} [linenumber]
+ }} [linenumber]}}
} 5
rename linenumber {}
diff --git a/tests/encoding.test b/tests/encoding.test
index 51b7aa1..b4ee7c3 100644
--- a/tests/encoding.test
+++ b/tests/encoding.test
@@ -582,6 +582,14 @@ file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout]
# EscapeFreeProc, GetTableEncoding, unilen are fully tested by the rest of
# this file.
+
+test encoding-27.1 {encoding dirs basic behavior} -returnCodes error -body {
+ encoding dirs ? ?
+} -result {wrong # args: should be "encoding dirs ?dirList?"}
+test encoding-27.2 {encoding dirs basic behavior} -returnCodes error -body {
+ encoding dirs "\{not a list"
+} -result "expected directory list but got \"\{not a list\""
+
}
runtests
diff --git a/tests/fCmd.test b/tests/fCmd.test
index 410e610..72b7da9 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -15,6 +15,8 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+cd [temporaryDirectory]
+
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint winVista 0
@@ -37,6 +39,7 @@ if {[testConstraint win]} {
}
}
+set tmpspace /tmp;# default value
# Find a group that exists on this Unix system, or else skip tests that
# require Unix groups.
testConstraint foundGroup [expr {![testConstraint unix]}]
@@ -46,6 +49,15 @@ if {[testConstraint unix]} {
set group [lindex $groupList 0]
testConstraint foundGroup 1
}
+
+ proc dev dir {
+ file stat $dir stat
+ return $stat(dev)
+ }
+
+ if {[catch {makeDirectory tcl[pid] /tmp} tmpspace] == 0} {
+ testConstraint xdev [expr {([dev .] != [dev $tmpspace])}]
+ }
}
# Also used in winFCmd...
@@ -149,13 +161,6 @@ proc contents {file} {
return $r
}
-cd [temporaryDirectory]
-
-proc dev dir {
- file stat $dir stat
- return $stat(dev)
-}
-testConstraint xdev [expr {[testConstraint unix] && ([dev .] != [dev /tmp])}]
set root [lindex [file split [pwd]] 0]
@@ -586,12 +591,12 @@ test fCmd-6.18 {CopyRenameOneFile: errno != EXDEV} -setup {
} -returnCodes error -match glob -result \
[subst {error renaming "td2" to "[file join td1 td2]": file *}]
test fCmd-6.19 {CopyRenameOneFile: errno == EXDEV} -setup {
- cleanup /tmp
+ cleanup $tmpspace
} -constraints {unix notRoot} -body {
createfile tf1
- file rename tf1 /tmp
- glob -nocomplain tf* /tmp/tf1
-} -result {/tmp/tf1}
+ file rename tf1 $tmpspace
+ glob -nocomplain tf* [file join $tmpspace tf1]
+} -result [file join $tmpspace tf1]
test fCmd-6.20 {CopyRenameOneFile: errno == EXDEV} -constraints {win} -setup {
catch {file delete -force c:/tcl8975@ d:/tcl8975@}
} -body {
@@ -605,28 +610,29 @@ test fCmd-6.20 {CopyRenameOneFile: errno == EXDEV} -constraints {win} -setup {
catch {file delete -force d:/tcl8975@}
} -result {d:/tcl8975@}
test fCmd-6.21 {CopyRenameOneFile: copy/rename: S_ISDIR(source)} -setup {
- cleanup /tmp
+ cleanup $tmpspace
} -constraints {unix notRoot} -body {
file mkdir td1
- file rename td1 /tmp
- glob -nocomplain td* /tmp/td*
-} -result {/tmp/td1}
+ file rename td1 $tmpspace
+ glob -nocomplain td* [file join $tmpspace td*]
+} -result [file join $tmpspace td1]
test fCmd-6.22 {CopyRenameOneFile: copy/rename: !S_ISDIR(source)} -setup {
- cleanup /tmp
+ cleanup $tmpspace
} -constraints {unix notRoot} -body {
createfile tf1
- file rename tf1 /tmp
- glob -nocomplain tf* /tmp/tf*
-} -result {/tmp/tf1}
+ file rename tf1 $tmpspace
+ glob -nocomplain tf* [file join $tmpspace tf*]
+} -result [file join $tmpspace tf1]
test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} -setup {
- cleanup /tmp
-} -constraints {unix notRoot xdev} -body {
+ cleanup $tmpspace
+} -constraints {xdev notRoot} -body {
file mkdir td1/td2/td3
file attributes td1 -permissions 0000
- file rename td1 /tmp
+ file rename td1 $tmpspace
} -returnCodes error -cleanup {
file attributes td1 -permissions 0755
-} -match regexp -result {^error renaming "td1"( to "/tmp/td1")?: permission denied$}
+ cleanup
+} -match regexp -result {^error renaming "td1"( to "/tmp/tcl\d+/td1")?: permission denied$}
test fCmd-6.24 {CopyRenameOneFile: error uses original name} -setup {
cleanup
} -constraints {unix notRoot} -body {
@@ -662,54 +668,54 @@ test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} -setup {
file delete -force ~/td1
} -result "error copying \"~/td1\" to \"td1\": \"[file join $::env(HOME) td1 td2]\": permission denied"
test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} -setup {
- cleanup /tmp
-} -constraints {unix notRoot xdev} -returnCodes error -body {
+ cleanup $tmpspace
+} -constraints {notRoot xdev} -returnCodes error -body {
file mkdir td1/td2/td3
- file mkdir /tmp/td1
- createfile /tmp/td1/tf1
- file rename -force td1 /tmp
-} -result {error renaming "td1" to "/tmp/td1": file already exists}
+ file mkdir [file join $tmpspace td1]
+ createfile [file join $tmpspace td1 tf1]
+ file rename -force td1 $tmpspace
+} -match glob -result {error renaming "td1" to "/tmp/tcl*/td1": file already exists}
test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} -setup {
- cleanup /tmp
-} -constraints {unix notRoot xdev} -body {
+ cleanup $tmpspace
+} -constraints {notRoot xdev} -body {
file mkdir td1/td2/td3
file attributes td1/td2/td3 -permissions 0000
- file rename td1 /tmp
+ file rename td1 $tmpspace
} -returnCodes error -cleanup {
file attributes td1/td2/td3 -permissions 0755
-} -result {error renaming "td1" to "/tmp/td1": "td1/td2/td3": permission denied}
+ cleanup $tmpspace
+} -match glob -result {error renaming "td1" to "/tmp/tcl*/td1": "td1/td2/td3": permission denied}
test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} -setup {
- cleanup /tmp
-} -constraints {unix notRoot xdev} -body {
+ cleanup $tmpspace
+} -constraints {notRoot xdev} -body {
file mkdir td1/td2/td3
- file rename td1 /tmp
- glob td* /tmp/td1/t*
-} -result {/tmp/td1/td2}
+ file rename td1 $tmpspace
+ glob td* [file join $tmpspace td1 t*]
+} -result [file join $tmpspace td1 td2]
test fCmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} -setup {
- cleanup
+ cleanup $tmpspace
} -constraints {unix notRoot} -body {
file mkdir foo/bar
file attr foo -perm 040555
- file rename foo/bar /tmp
+ file rename foo/bar $tmpspace
} -returnCodes error -cleanup {
- catch {file delete /tmp/bar}
+ catch {file delete [file join $tmpspace bar]}
catch {file attr foo -perm 040777}
catch {file delete -force foo}
} -match glob -result {*: permission denied}
test fCmd-6.31 {CopyRenameOneFile: TclpDeleteFile passed} -setup {
- catch {cleanup /tmp}
-} -constraints {unix notRoot xdev} -body {
- file mkdir /tmp/td1
- createfile /tmp/td1/tf1
- file rename /tmp/td1/tf1 tf1
- list [file exists /tmp/td1/tf1] [file exists tf1]
+ cleanup $tmpspace
+} -constraints {notRoot xdev} -body {
+ file mkdir [file join $tmpspace td1]
+ createfile [file join $tmpspace td1 tf1]
+ file rename [file join $tmpspace td1 tf1] tf1
+ list [file exists [file join $tmpspace td1 tf1]] [file exists tf1]
} -result {0 1}
test fCmd-6.32 {CopyRenameOneFile: copy} -constraints {notRoot} -setup {
cleanup
} -returnCodes error -body {
file copy tf1 tf2
} -result {error copying "tf1": no such file or directory}
-catch {cleanup /tmp}
test fCmd-7.1 {FileForceOption: none} -constraints {notRoot} -setup {
cleanup
@@ -1347,23 +1353,23 @@ test fCmd-12.8 {renamefile: generic error} -setup {
file delete -force tfa
} -result {1}
test fCmd-12.9 {renamefile: moving a file across volumes} -setup {
- catch {file delete -force -- tfa /tmp/tfa}
+ cleanup $tmpspace
} -constraints {unix notRoot} -body {
set s [createfile tfa]
- file rename tfa /tmp
- list [checkcontent /tmp/tfa $s] [file exists tfa]
+ file rename tfa $tmpspace
+ list [checkcontent [file join $tmpspace tfa] $s] [file exists tfa]
} -cleanup {
- file delete /tmp/tfa
+ cleanup $tmpspace
} -result {1 0}
test fCmd-12.10 {renamefile: moving a directory across volumes} -setup {
- catch {file delete -force -- tfad /tmp/tfad}
-} -constraints {unix notRoot} -body {
+ cleanup $tmpspace
+} -constraints {xdev notRoot} -body {
file mkdir tfad
set s [createfile tfad/a]
- file rename tfad /tmp
- list [checkcontent /tmp/tfad/a $s] [file exists tfad]
+ file rename tfad $tmpspace
+ list [checkcontent [file join $tmpspace tfad a] $s] [file exists tfad]
} -cleanup {
- file delete -force /tmp/tfad
+ cleanup $tmpspace
} -result {1 0}
#
@@ -2583,6 +2589,9 @@ test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win} -body {
# cleanup
cleanup
+if {[testConstraint unix]} {
+ removeDirectory tcl[pid] /tmp
+}
::tcltest::cleanupTests
return
diff --git a/tests/fileName.test b/tests/fileName.test
index affacff..251f12c 100644
--- a/tests/fileName.test
+++ b/tests/fileName.test
@@ -196,7 +196,7 @@ test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} {
test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split //foo
-} {/ foo}
+} "[file split //] foo"
test filename-4.14 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split foo//bar
@@ -433,11 +433,11 @@ test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} {
test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join //a b
-} {/a/b}
+} "[file split //]a/b"
test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /// a b
-} {/a/b}
+} "[file split //]a/b"
test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
diff --git a/tests/fileSystem.test b/tests/fileSystem.test
index 9950dde..64f4d45 100644
--- a/tests/fileSystem.test
+++ b/tests/fileSystem.test
@@ -305,7 +305,7 @@ test filesystem-1.39 {file normalisation with volume relative} -setup {
file norm [string range $drv 0 1]
} -cleanup {
cd $old
-} -match glob -result {*[^/]}
+} -match regexp -result {.*[^/]}
test filesystem-1.40 {file normalisation with repeated separators} {
testPathEqual [file norm foo////bar] [file norm foo/bar]
} ok
diff --git a/tests/http.test b/tests/http.test
index 37d4a05..fe44b47 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -135,6 +135,7 @@ set fullurl http://user:pass@[info hostname]:$port/a/b/c
set binurl //[info hostname]:$port/binary
set posturl //[info hostname]:$port/post
set badposturl //[info hostname]:$port/droppost
+set ipv6url http://\[::1\]:$port/
test http-3.4 {http::geturl} -body {
set token [http::geturl $url]
http::data $token
@@ -390,6 +391,12 @@ Connection close
Content-Type {text/plain;charset=utf-8}
Accept-Encoding .*
Content-Length 5}
+test http-3.29 "http::geturl $ipv6url" -body {
+ set token [http::geturl $ipv6url -validate 1]
+ http::code $token
+} -cleanup {
+ http::cleanup $token
+} -result "HTTP/1.0 200 OK"
test http-4.1 {http::Event} -body {
set token [http::geturl $url -keepalive 0]
diff --git a/tests/io.test b/tests/io.test
index 53b85fa..f3c39f4 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -2086,6 +2086,8 @@ set path(pipe) [makeFile {} pipe]
set path(output) [makeFile {} output]
test io-27.6 {FlushChannel, async flushing, async close} \
{stdio asyncPipeClose openpipe} {
+ # This test may fail on old Unix systems (seen on IRIX64 6.5) with
+ # obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197.
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
@@ -2645,6 +2647,8 @@ test io-29.30 {Tcl_WriteChars, crlf mode} {
file size $path(test1)
} 25
test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} {
+ # This test may fail on old Unix systems (seen on IRIX64 6.5) with
+ # obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197.
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
@@ -2686,6 +2690,8 @@ test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} {
} ok
test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
{stdio asyncPipeClose openpipe} {
+ # This test may fail on old Unix systems (seen on IRIX64 6.5) with
+ # obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197.
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
@@ -2736,6 +2742,26 @@ test io-29.33 {Tcl_Flush, implicit flush on exit} {exec} {
close $f
set r
} "hello\nbye\nstrange\n"
+set path(script2) [makeFile {} script2]
+test io-29.33b {TIP#398, no implicit flush of nonblocking on exit} {exec} {
+ set f [open $path(script) w]
+ puts $f {
+ fconfigure stdout -blocking 0
+ puts -nonewline stdout [string repeat A 655360]
+ flush stdout
+ }
+ close $f
+ set f [open $path(script2) w]
+ puts $f {after 2000}
+ close $f
+ set t1 [clock milliseconds]
+ set ff [open "|[list [interpreter] $path(script2)]" w]
+ catch {unset ::env(TCL_FLUSH_NONBLOCKING_ON_EXIT)}
+ exec [interpreter] $path(script) >@ $ff
+ set t2 [clock milliseconds]
+ close $ff
+ expr {($t2-$t1)/2000 ? $t2-$t1 : 0}
+} 0
test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac fileevent} {
variable c 0
variable x running
@@ -7761,7 +7787,7 @@ test io-73.2 {channel Tcl_Obj SetChannelFromAny, bug 2407783} -setup {
# ### ### ### ######### ######### #########
# cleanup
-foreach file [list fooBar longfile script output test1 pipe my_script \
+foreach file [list fooBar longfile script script2 output test1 pipe my_script \
test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] {
removeFile $file
}
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 4c08229..cf913ff 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -2575,6 +2575,7 @@ test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at thi
set res
} -cleanup {
proc foo {args} {onfinal; set ::done-24.15 1; return 3}
+ after 1000 {set ::done-24.15 2}
vwait done-24.15
rename foo {}
unset res
@@ -2603,16 +2604,132 @@ test iocmd.tf-24.16 {chan write, note the background flush setup by close due to
proc foo {args} { onfinal; note BG ; track ; set ::endbody-24.16 1}
# Flush (sic!) the event-queue to capture the write from a
# BG-flush.
+ after 1000 {set ::endbody-24.16 2}
vwait endbody-24.16
set res
} -cleanup {
proc foo {args} {onfinal; set ::done-24.16 1; return 3}
+ after 1000 {set ::done-24.16 2}
vwait done-24.16
rename foo {}
unset res
} -result {{write rc* ABC} {watch rc* write} {} BG {write rc* ABC}} \
-constraints {testchannel thread}
+test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \
+ -constraints {testchannel thread} -setup {
+ # This test exposes how the execution of postevent in the handler thread causes
+ # a crash if we are not properly injecting the events into the owning thread instead.
+ # With the injection the test will simply complete without crash.
+
+ set beat 10000
+ set drive 999
+ set data ...---...
+
+ proc LOG {text} {
+ #puts stderr "[thread::id]: $text"
+ return
+ }
+
+ proc POST {hi} {
+ LOG "-> [info level 0]"
+ chan postevent $hi read
+ LOG "<- [info level 0]"
+
+ set ::timer [after $::drive [info level 0]]
+ return
+ }
+
+ proc HANDLER {op ch args} {
+ lappend ::res [lrange [info level 0] 1 end]
+ LOG "-> [info level 0]"
+ set ret {}
+ switch -glob -- $op {
+ init* {set ret {initialize finalize watch read}}
+ watch {
+ set l [lindex $args 0]
+ if {[llength $l]} {
+ set ::timer [after $::drive [list POST $ch]]
+ } else {
+ after cancel $::timer
+ }
+ }
+ finalize {
+ catch { after cancel $::timer }
+ after 500 {set ::forever now}
+ }
+ read {
+ set ret $::data
+ set ::data {} ; # Next is EOF.
+ }
+ }
+ LOG "<- [info level 0] : $ret"
+ return $ret
+ }
+} -body {
+ LOG BEGIN
+ set ch [chan create {read} HANDLER]
+
+ set tid [thread::create {
+ proc LOG {text} {
+ #puts stderr "\t\t\t\t\t\t[thread::id]: $text"
+ return
+ }
+ LOG THREAD-STARTED
+ load {} Tcltest
+ proc bgerror s {
+ LOG BGERROR:$s
+ }
+ vwait forever
+ LOG THREAD-DONE
+ }]
+
+ testchannel cut $ch
+ thread::send $tid [list set thech $ch]
+ thread::send $tid [list set beat $beat]
+ thread::send -async $tid {
+ LOG SPLICE-BEG
+ testchannel splice $thech
+ LOG SPLICE-END
+ proc PROCESS {ch} {
+ LOG "-> [info level 0]"
+ if {[eof $ch]} {
+ close $ch
+ set ::done 1
+ set c <<EOF>>
+ } else {
+ set c [read $ch 1]
+ }
+ LOG "GOTCHAR: $c"
+ LOG "<- [info level 0]"
+ }
+ LOG THREAD-FILEEVENT
+ fconfigure $thech -translation binary -blocking 0
+ fileevent $thech readable [list PROCESS $thech]
+ LOG THREAD-NOEVENT-LOOP
+ set done 0
+ while {!$done} {
+ after $beat
+ LOG THREAD-HEARTBEAT
+ update
+ }
+ LOG THREAD-LOOP-DONE
+ thread::exit
+ }
+
+ LOG MAIN_WAITING
+ vwait forever
+ LOG MAIN_DONE
+
+ set res
+} -cleanup {
+ rename LOG {}
+ rename POST {}
+ rename HANDLER {}
+ unset beat drive data forever res tid ch
+} -match glob \
+ -result {{initialize rc* read} {watch rc* read} {read rc* 4096} {watch rc* {}} {watch rc* read} {read rc* 4096} {watch rc* {}} {finalize rc*}}
+
# --- === *** ###########################
# method cgetall
diff --git a/tests/msgcat.test b/tests/msgcat.test
index 0669810..bbcd023 100644
--- a/tests/msgcat.test
+++ b/tests/msgcat.test
@@ -17,8 +17,8 @@ if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
-if {[catch {package require msgcat 1.4.2}]} {
- puts stderr "Skipping tests in [info script]. No msgcat 1.4.2 found to test."
+if {[catch {package require msgcat 1.4.5}]} {
+ puts stderr "Skipping tests in [info script]. No msgcat 1.4.5 found to test."
return
}
diff --git a/tests/oo.test b/tests/oo.test
index f3c0bda..00663e9 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -1974,7 +1974,7 @@ test oo-18.1 {OO: define command support} {
} {1 foo {foo
while executing
"error foo"
- (in definition script for object "oo::object" line 1)
+ (in definition script for class "::oo::object" line 1)
invoked from within
"oo::define oo::object {error foo}"}}
test oo-18.2 {OO: define command support} {
@@ -1987,7 +1987,7 @@ test oo-18.3 {OO: define command support} {
} {1 bar {bar
while executing
"error bar"
- (in definition script for object "::foo" line 1)
+ (in definition script for class "::foo" line 1)
invoked from within
"oo::class create foo {error bar}"}}
test oo-18.3a {OO: define command support} {
@@ -1997,7 +1997,7 @@ test oo-18.3a {OO: define command support} {
} {1 bar {bar
while executing
"error bar"
- (in definition script for object "::foo" line 2)
+ (in definition script for class "::foo" line 2)
invoked from within
"oo::class create foo {
error bar
@@ -2015,7 +2015,7 @@ test oo-18.3b {OO: define command support} {
("eval" body line 1)
invoked from within
"eval eval error bar"
- (in definition script for object "::foo" line 2)
+ (in definition script for class "::foo" line 2)
invoked from within
"oo::class create foo {
eval eval error bar
@@ -2070,6 +2070,106 @@ test oo-18.5 {OO: more error traces from the guts} -setup {
(class "::cls" method "eval" line 1)
invoked from within
"obj eval {error bar}"}}
+test oo-18.6 {class construction reference management and errors} -setup {
+ oo::class create super_abc
+} -body {
+ catch {
+oo::class create abc {
+ superclass super_abc
+ ::rename abc ::def
+ ::error foo
+}
+ } msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ super_abc destroy
+} -result {foo
+ while executing
+"::error foo"
+ (in definition script for class "::def" line 4)
+ invoked from within
+"oo::class create abc {
+ superclass super_abc
+ ::rename abc ::def
+ ::error foo
+}"}
+test oo-18.7 {OO: objdefine command support} -setup {
+ oo::object create ::inst
+} -body {
+ list [catch {oo::objdefine inst {rename ::inst ::INST;error foo}} msg] $msg $errorInfo
+} -cleanup {
+ catch {::inst destroy}
+ catch {::INST destroy}
+} -result {1 foo {foo
+ while executing
+"error foo"
+ (in definition script for object "::INST" line 1)
+ invoked from within
+"oo::objdefine inst {rename ::inst ::INST;error foo}"}}
+test oo-18.8 {OO: define/self command support} -setup {
+ oo::class create master
+ oo::class create ::foo {superclass master}
+} -body {
+ catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {foobar
+ while executing
+"error foobar"
+ (in definition script for class object "::bar" line 1)
+ invoked from within
+"self {error foobar}"
+ (in definition script for class "::bar" line 1)
+ invoked from within
+"oo::define foo {rename ::foo ::bar; self {error foobar}}"}
+test oo-18.9 {OO: define/self command support} -setup {
+ oo::class create master
+ set c [oo::class create now_this_is_a_very_very_long_class_name_indeed {
+ superclass master
+ }]
+} -body {
+ catch {oo::define $c {error err}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {err
+ while executing
+"error err"
+ (in definition script for class "::now_this_is_a_very_very_long..." line 1)
+ invoked from within
+"oo::define $c {error err}"}
+test oo-18.10 {OO: define/self command support} -setup {
+ oo::class create master
+ oo::class create ::foo {superclass master}
+} -body {
+ catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {foobar
+ while executing
+"error foobar"
+ (in definition script for class object "::foo" line 1)
+ invoked from within
+"self {rename ::foo {}; error foobar}"
+ (in definition script for class "::foo" line 1)
+ invoked from within
+"oo::define foo {self {rename ::foo {}; error foobar}}"}
+test oo-18.11 {OO: define/self command support} -setup {
+ oo::class create master
+ oo::class create ::foo {superclass master}
+} -body {
+ catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {this command cannot be called when the object has been deleted
+ while executing
+"self {error foobar}"
+ (in definition script for class "::foo" line 1)
+ invoked from within
+"oo::define foo {rename ::foo {}; self {error foobar}}"}
test oo-19.1 {OO: varname method} -setup {
oo::object create inst
@@ -3189,7 +3289,7 @@ test oo-33.2 {TIP 380: slots - defaulting} -setup {
} -cleanup {
rename $s {}
} -result {{} {a b c destroy unknown}}
-test oo-32.3 {TIP 380: slots - defaulting} -setup {
+test oo-33.3 {TIP 380: slots - defaulting} -setup {
set s [SampleSlot new]
} -body {
oo::objdefine $s forward --default-operation my -set
diff --git a/tests/platform.test b/tests/platform.test
index 8cb8dcd..92ca7ab 100644
--- a/tests/platform.test
+++ b/tests/platform.test
@@ -14,7 +14,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
-testConstraint testWinCPUID [llength [info commands testwincpuid]]
+testConstraint testCPUID [llength [info commands testcpuid]]
test platform-1.1 {TclpSetVariables: tcl_platform} {
interp create i
@@ -36,12 +36,12 @@ test platform-2.1 {tcl_platform(wordSize) indicates size of native word} {
list [expr {$result < 0}] [expr {$result ^ int($result - 1)}]
} {1 -1}
-# On Windows, test that the CPU ID works
+# On Windows/UNIX, test that the CPU ID works
-test platform-3.1 {CPU ID on Windows } \
- -constraints testWinCPUID \
+test platform-3.1 {CPU ID on Windows/UNIX} \
+ -constraints testCPUID \
-body {
- set cpudata [testwincpuid 0]
+ set cpudata [testcpuid 0]
binary format iii \
[lindex $cpudata 1] \
[lindex $cpudata 3] \
diff --git a/tests/proc.test b/tests/proc.test
index ed3c4b6..e06720e 100644
--- a/tests/proc.test
+++ b/tests/proc.test
@@ -374,6 +374,15 @@ test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} -body {
} -cleanup {
namespace delete ugly
} -result 4
+
+test proc-7.4 {Proc struct outlives its interp: Bug 3532959} {
+ set lambda x
+ lappend lambda {set a 1}
+ interp create slave
+ slave eval [list apply $lambda foo]
+ interp delete slave
+ unset lambda
+} {}
# cleanup
catch {rename p ""}
diff --git a/tests/registry.test b/tests/registry.test
index 7234a32..400277f 100644
--- a/tests/registry.test
+++ b/tests/registry.test
@@ -505,6 +505,12 @@ test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} {
registry delete HKEY_CURRENT_USER\\TclFoobar
set result
} "foo ba r baz"
+test registry-6.21 {GetValue: very long value names and values} {pcOnly} {
+ registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383] [string repeat x 16383] multi_sz
+ set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383]]
+ registry delete HKEY_CURRENT_USER\\TclFoobar
+ set result
+} [string repeat x 16383]
test registry-7.1 {GetValueNames: bad key} -constraints {win reg english} -setup {
registry delete HKEY_CURRENT_USER\\TclFoobar
diff --git a/tests/safe.test b/tests/safe.test
index 2d7f476..4a2792e 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -28,8 +28,6 @@ set ::auto_path [info library]
# thus un-autoindexed) APIs in this test result arguments:
catch {safe::interpConfigure}
-proc equiv {x} {return $x}
-
# testing that nested and statics do what is advertised (we use a static
# package - Tcltest - but it might be absent if we're in standard tclsh)
@@ -94,7 +92,7 @@ test safe-3.2 {calling safe::interpCreate on trusted interp} -setup {
lsort [a aliases]
} -cleanup {
safe::interpDelete a
-} -result {::tcl::info::nameofexecutable clock encoding exit file glob load source}
+} -result {::tcl::file::atime ::tcl::file::attributes ::tcl::file::copy ::tcl::file::delete ::tcl::file::dirname ::tcl::file::executable ::tcl::file::exists ::tcl::file::extension ::tcl::file::isdirectory ::tcl::file::isfile ::tcl::file::link ::tcl::file::lstat ::tcl::file::mkdir ::tcl::file::mtime ::tcl::file::nativename ::tcl::file::normalize ::tcl::file::owned ::tcl::file::readable ::tcl::file::readlink ::tcl::file::rename ::tcl::file::rootname ::tcl::file::size ::tcl::file::stat ::tcl::file::tail ::tcl::file::tempfile ::tcl::file::type ::tcl::file::volumes ::tcl::file::writable ::tcl::info::nameofexecutable clock encoding exit glob load source}
test safe-3.3 {calling safe::interpCreate on trusted interp} -setup {
catch {safe::interpDelete a}
} -body {
@@ -206,6 +204,11 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body {
[safe::interpConfigure $i]\
[safe::interpDelete $i]
} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}"
+test safe-7.3 {check that safe subinterpreters work} {
+ set i [safe::interpCreate]
+ set j [safe::interpCreate [list $i x]]
+ list [interp eval $j {join {o k} ""}] [safe::interpDelete $i] [interp exists $j]
+} {ok {} 0}
# test source control on file name
test safe-8.1 {safe source control on file} -setup {
@@ -331,6 +334,20 @@ test safe-8.9 {safe source and return} -setup {
catch {safe::interpDelete $i}
removeFile $returnScript
} -result ok
+test safe-8.10 {safe source and return} -setup {
+ set returnScript [makeFile {return -level 2 "ok"} return.tcl]
+ catch {safe::interpDelete $i}
+} -body {
+ safe::interpCreate $i
+ set token [safe::interpAddToAccessPath $i [file dirname $returnScript]]
+ $i eval [list apply {filename {
+ source $filename
+ error boom
+ }} $token/[file tail $returnScript]]
+} -cleanup {
+ catch {safe::interpDelete $i}
+ removeFile $returnScript
+} -result ok
test safe-9.1 {safe interps' deleteHook} -setup {
set i "a"
@@ -538,11 +555,154 @@ test safe-12.7 {glob is restricted} -setup {
set i [safe::interpCreate]
} -body {
$i eval glob *
+} -returnCodes error -cleanup {
+ safe::interpDelete $i
+} -result {permission denied}
+
+proc buildEnvironment {filename} {
+ upvar 1 testdir testdir testdir2 testdir2 testfile testfile
+ set testdir [makeDirectory deletethisdir]
+ set testdir2 [makeDirectory deletemetoo $testdir]
+ set testfile [makeFile {} $filename $testdir2]
+}
+#### New tests for Safe base glob, with patches @ Bug 2964715
+test safe-13.1 {glob is restricted [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+} -body {
+ $i eval glob *
+} -returnCodes error -cleanup {
+ safe::interpDelete $i
+} -result {permission denied}
+test safe-13.2 {mimic the valid glob call by ::tcl::tm::UnknownHandler [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment deleteme.tm
+} -body {
+ ::safe::interpAddToAccessPath $i $testdir2
+ set result [$i eval glob -nocomplain -directory $testdir2 *.tm]
+ if {$result eq [list $testfile]} {
+ return "glob match"
+ } else {
+ return "no match: $result"
+ }
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {glob match}
+test safe-13.3 {cf 13.2 but test glob failure when -directory is outside access path [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment deleteme.tm
+} -body {
+ $i eval glob -directory $testdir2 *.tm
+} -returnCodes error -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {permission denied}
+test safe-13.4 {another valid glob call [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment deleteme.tm
+} -body {
+ ::safe::interpAddToAccessPath $i $testdir
+ ::safe::interpAddToAccessPath $i $testdir2
+ set result [$i eval \
+ glob -nocomplain -directory $testdir [file join deletemetoo *.tm]]
+ if {$result eq [list $testfile]} {
+ return "glob match"
+ } else {
+ return "no match: $result"
+ }
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {glob match}
+test safe-13.5 {as 13.4 but test glob failure when -directory is outside access path [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment deleteme.tm
+} -body {
+ ::safe::interpAddToAccessPath $i $testdir2
+ $i eval \
+ glob -directory $testdir [file join deletemetoo *.tm]
+} -returnCodes error -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {permission denied}
+test safe-13.6 {as 13.4 but test silent failure when result is outside access_path [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment deleteme.tm
+} -body {
+ ::safe::interpAddToAccessPath $i $testdir
+ $i eval \
+ glob -nocomplain -directory $testdir [file join deletemetoo *.tm]
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {}
+test safe-13.7 {mimic the glob call by tclPkgUnknown which gives a deliberate error in a safe interpreter [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment pkgIndex.tcl
+} -body {
+ set safeTD [::safe::interpAddToAccessPath $i $testdir]
+ ::safe::interpAddToAccessPath $i $testdir2
+ string map [list $safeTD EXPECTED] [$i eval [list \
+ glob -directory $safeTD -join * pkgIndex.tcl]]
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {{EXPECTED/deletemetoo/pkgIndex.tcl}}
+# Note the extra {} around the result above; that's *expected* because of the
+# format of virtual path roots.
+test safe-13.8 {mimic the glob call by tclPkgUnknown without the deliberate error that is specific to pkgIndex.tcl [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment notIndex.tcl
+} -body {
+ set safeTD [::safe::interpAddToAccessPath $i $testdir]
+ ::safe::interpAddToAccessPath $i $testdir2
+ $i eval [list glob -directory $safeTD -join -nocomplain * notIndex.tcl]
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {}
+test safe-13.9 {as 13.8 but test glob failure when -directory is outside access path [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment notIndex.tcl
+} -body {
+ ::safe::interpAddToAccessPath $i $testdir2
+ set result [$i eval \
+ glob -directory $testdir -join -nocomplain * notIndex.tcl]
+ if {$result eq [list $testfile]} {
+ return {glob match}
+ } else {
+ return "no match: $result"
+ }
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {no match: }
+test safe-13.10 {as 13.8 but test silent failure when result is outside access_path [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment notIndex.tcl
+} -body {
+ ::safe::interpAddToAccessPath $i $testdir
+ $i eval glob -directory $testdir -join -nocomplain * notIndex.tcl
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {}
+rename buildEnvironment {}
+
+#### Test for the module path
+test safe-14.1 {Check that module path is the same as in the master interpreter [Bug 2964715]} -setup {
+ set i [safe::interpCreate]
+} -body {
+ set tm {}
+ foreach token [$i eval ::tcl::tm::path list] {
+ lappend tm [dict get [set ::safe::S${i}(access_path,map)] $token]
+ }
+ return $tm
} -cleanup {
safe::interpDelete $i
-} -match glob -result *
+} -result [::tcl::tm::path list]
-test safe-13.1 {safe file ensemble does not surprise code} -setup {
+test safe-15.1 {safe file ensemble does not surprise code} -setup {
set i [interp create -safe]
} -body {
set result [expr {"file" in [interp hidden $i]}]
@@ -556,7 +716,53 @@ test safe-13.1 {safe file ensemble does not surprise code} -setup {
lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg
} -cleanup {
interp delete $i
-} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {invalid command name "::tcl::file::isdirectory"}}
+} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}}
+
+### ~ should have no special meaning in paths in safe interpreters
+test safe-16.1 {Bug 3529949: defang ~ in paths} -setup {
+ set savedHOME $env(HOME)
+ set env(HOME) /foo/bar
+ set i [safe::interpCreate]
+} -body {
+ $i eval {
+ set d [format %c 126]
+ list [file join [file dirname $d] [file tail $d]]
+ }
+} -cleanup {
+ safe::interpDelete $i
+ set env(HOME) $savedHOME
+} -result {./~}
+test safe-16.2 {Bug 3529949: defang ~user in paths} -setup {
+ set i [safe::interpCreate]
+ set user $tcl_platform(user)
+} -body {
+ string map [list $user USER] [$i eval \
+ "file join \[file dirname ~$user\] \[file tail ~$user\]"]
+} -cleanup {
+ safe::interpDelete $i
+} -result {./~USER}
+test safe-16.3 {Bug 3529949: defang ~ in globs} -setup {
+ set syntheticHOME [makeDirectory foo]
+ makeFile {} bar $syntheticHOME
+ set savedHOME $env(HOME)
+ set env(HOME) $syntheticHOME
+ set i [safe::interpCreate]
+} -body {
+ ::safe::interpAddToAccessPath $i $syntheticHOME
+ $i eval {glob -nocomplain ~/*}
+} -cleanup {
+ safe::interpDelete $i
+ set env(HOME) $savedHOME
+ removeDirectory $syntheticHOME
+} -result {}
+test safe-16.4 {Bug 3529949: defang ~user in globs} -setup {
+ set i [safe::interpCreate]
+} -body {
+ ::safe::interpAddToAccessPath $i $~$tcl_platform(user)
+ $i eval [list glob -nocomplain ~$tcl_platform(user)/*]
+} -cleanup {
+ safe::interpDelete $i
+} -result {}
set ::auto_path $saveAutoPath
# cleanup
diff --git a/tests/socket.test b/tests/socket.test
index f63f5ca..9f1cc78 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -64,7 +64,7 @@ package require tcltest 2
namespace import -force ::tcltest::*
# Some tests require the Thread package or exec command
-testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
+testConstraint thread [expr {0 == [catch {package require Thread 2.6.6}]}]
testConstraint exec [llength [info commands exec]]
# Produce a random port number in the Dynamic/Private range
@@ -1696,6 +1696,7 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -body {
set i 0
vwait x
close $f
+ thread::wait
}]]
set port [thread::send $serverthread {set listen}]
set s [socket $localhost $port]
@@ -1776,17 +1777,20 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \
test socket-14.2 {[socket -async] fileevent connection refused} \
-constraints [list socket supported_any] \
-body {
- set client [socket -async localhost [randport]]
- fileevent $client writable {set x [fconfigure $client -error]}
- set after [after 1000 {set x timeout}]
- vwait x
- if {$x eq "timeout"} {
- append x ": [fconfigure $client -error]"
- }
+ 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
} -cleanup {
- after cancel $after
- close $client
unset x
} -result "connection refused"
test socket-14.3 {[socket -async] when server only listens on IPv6} \
diff --git a/tests/switch.test b/tests/switch.test
index 255be00..a03948b 100644
--- a/tests/switch.test
+++ b/tests/switch.test
@@ -536,7 +536,7 @@ test switch-11.6 {-matchvar unwritable} {
test switch-12.1 {regexp matching with -indexvar} {
switch -regexp -indexvar x -- abc {.(.). {set x}}
-} {{0 3} {1 2}}
+} {{0 2} {1 1}}
test switch-12.2 {regexp matching with -indexvar} {
set x GOOD
switch -regexp -indexvar x -- abc {.(.).. {list $x z}}
@@ -544,7 +544,7 @@ test switch-12.2 {regexp matching with -indexvar} {
} GOOD
test switch-12.3 {regexp matching with -indexvar} {
switch -regexp -indexvar x -- "a b c" {.(.). {set x}}
-} {{0 3} {1 2}}
+} {{0 2} {1 1}}
test switch-12.4 {regexp matching with -indexvar} {
set x BAD
switch -regexp -indexvar x -- "a b c" {
@@ -560,22 +560,32 @@ test switch-12.6 {-indexvar unwritable} {
set x {}
list [catch {switch -regexp -indexvar x(x) -- abc . {set x}} msg] $x $msg
} {1 {} {can't set "x(x)": variable isn't array}}
+test switch-12.7 {[Bug 3106532] -indexvar should be directly usable with [string range]} {
+ set str abcdef
+ switch -regexp -indexvar x -- $str ^... {string range $str {*}[lindex $x 0]}
+} abc
+test switch-12.8 {-indexvar and matched empty strings} {
+ switch -regexp -indexvar x -- abcdef ^...(x?) {return $x}
+} {{0 2} {3 2}}
+test switch-12.9 {-indexvar and unmatched strings} {
+ switch -regexp -indexvar x -- abcdef ^...(x)? {return $x}
+} {{0 2} {-1 -1}}
test switch-13.1 {-indexvar -matchvar combinations} {
switch -regexp -indexvar x -matchvar y abc {
. {list $x $y}
}
-} {{{0 1}} a}
+} {{{0 0}} a}
test switch-13.2 {-indexvar -matchvar combinations} {
switch -regexp -indexvar x -matchvar y abc {
.$ {list $x $y}
}
-} {{{2 3}} c}
+} {{{2 2}} c}
test switch-13.3 {-indexvar -matchvar combinations} {
switch -regexp -indexvar x -matchvar y abc {
(.)(.)(.) {list $x $y}
}
-} {{{0 3} {0 1} {1 2} {2 3}} {abc a b c}}
+} {{{0 2} {0 0} {1 1} {2 2}} {abc a b c}}
test switch-13.4 {-indexvar -matchvar combinations} {
set x -
set y -
@@ -597,7 +607,7 @@ test switch-13.6 {-indexvar -matchvar combinations} {
list [catch {
switch -regexp -indexvar x -matchvar y(y) abc {. {list $x $y}}
} msg] $x $y $msg
-} {1 {{0 1}} - {can't set "y(y)": variable isn't array}}
+} {1 {{0 0}} - {can't set "y(y)": variable isn't array}}
test switch-14.1 {-regexp -- compilation [Bug 1854399]} {
switch -regexp -- 0 {
diff --git a/tests/winDde.test b/tests/winDde.test
index ca50a96..83f3598 100644
--- a/tests/winDde.test
+++ b/tests/winDde.test
@@ -15,18 +15,16 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
-if {[testConstraint win]} {
- if [catch {
- # Is the dde extension already static to this shell?
- if [catch {load {} Dde; set ::ddelib {}}] {
- # try the location given to use on the commandline to tcltest
- ::tcltest::loadTestedCommands
- load $::ddelib Dde
- }
- testConstraint dde 1
- }] {
- testConstraint dde 0
+if [catch {
+ # Is the dde extension already static to this shell?
+ if [catch {load {} Dde; set ::ddelib {}}] {
+ # try the location given to use on the commandline to tcltest
+ ::tcltest::loadTestedCommands
+ load $::ddelib Dde
}
+ testConstraint dde 1
+}] {
+ testConstraint dde 0
}
@@ -36,7 +34,7 @@ if {[testConstraint win]} {
set scriptName [makeFile {} script1.tcl]
-proc createChildProcess { ddeServerName {handler {}}} {
+proc createChildProcess {ddeServerName args} {
file delete -force $::scriptName
set f [open $::scriptName w+]
@@ -51,7 +49,7 @@ proc createChildProcess { ddeServerName {handler {}}} {
package require tcltest
namespace import -force ::tcltest::*
}
-
+
# If an error occurs during the tests, this process may end up not
# being closed down. To deal with this we create a 30s timeout.
proc ::DoTimeout {} {
@@ -61,16 +59,19 @@ proc createChildProcess { ddeServerName {handler {}}} {
flush stdout
}
set timeout [after 30000 ::DoTimeout]
-
+
# Define a restricted handler.
proc Handler1 {cmd} {
if {$cmd eq "stop"} {set ::done 1}
- puts $cmd ; flush stdout
+ if {$cmd == ""} {
+ set cmd "null data"
+ }
+ puts $cmd ; flush stdout
return
}
proc Handler2 {cmd} {
if {$cmd eq "stop"} {set ::done 1}
- puts [uplevel \#0 $cmd] ; flush stdout
+ puts [uplevel \#0 $cmd] ; flush stdout
return
}
proc Handler3 {prefix cmd} {
@@ -80,11 +81,7 @@ proc createChildProcess { ddeServerName {handler {}}} {
}
}
# set the dde server name to the supplied argument.
- if {$handler == {}} {
- puts $f [list dde servername $ddeServerName]
- } else {
- puts $f [list dde servername -handler $handler -- $ddeServerName]
- }
+ puts $f [list dde servername {*}$args -- $ddeServerName]
puts $f {
# run the server and handle final cleanup.
after 200;# give dde a chance to get going.
@@ -94,12 +91,12 @@ proc createChildProcess { ddeServerName {handler {}}} {
# allow enough time for the calling process to
# claim all results, to avoid spurious "server did
# not respond"
- after 200 { set reallyDone 1 }
+ after 200 {set reallyDone 1}
vwait reallyDone
exit
}
close $f
-
+
# run the child server script.
set f [open |[list [interpreter] $::scriptName] r]
fconfigure $f -buffering line
@@ -109,146 +106,160 @@ proc createChildProcess { ddeServerName {handler {}}} {
# -------------------------------------------------------------------------
-test winDde-1.1 {Settings the server's topic name} {win dde} {
+test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
list [dde servername foobar] [dde servername] [dde servername self]
-} {foobar foobar self}
+} -result {foobar foobar self}
-test winDde-2.1 {Checking for other services} {win dde} {
+test winDde-2.1 {Checking for other services} -constraints dde -body {
expr [llength [dde services {} {}]] >= 0
-} 1
+} -result 1
test winDde-2.2 {Checking for existence, with service and topic specified} \
- {win dde} {
+ -constraints dde -body {
llength [dde services TclEval self]
-} 1
+} -result 1
test winDde-2.3 {Checking for existence, with only the service specified} \
- {win dde} {
+ -constraints dde -body {
expr [llength [dde services TclEval {}]] >= 1
-} 1
+} -result 1
test winDde-2.4 {Checking for existence, with only the topic specified} \
- {win dde} {
+ -constraints dde -body {
expr [llength [dde services {} self]] >= 1
-} 1
+} -result 1
# -------------------------------------------------------------------------
-test winDde-3.1 {DDE execute locally} {win dde} {
- set a ""
- dde execute TclEval self {set a "foo"}
- set a
-} foo
-test winDde-3.2 {DDE execute -async locally} {win dde} {
- set a ""
- dde execute -async TclEval self {set a "foo"}
+test winDde-3.1 {DDE execute locally} -constraints dde -body {
+ set \xe1 ""
+ dde execute TclEval self [list set \xe1 foo]
+ set \xe1
+} -result foo
+test winDde-3.2 {DDE execute -async locally} -constraints dde -body {
+ set \xe1 ""
+ dde execute -async TclEval self [list set \xe1 foo]
update
- set a
-} foo
-test winDde-3.3 {DDE request locally} {win dde} {
+ set \xe1
+} -result foo
+test winDde-3.3 {DDE request locally} -constraints dde -body {
set a ""
- dde execute TclEval self {set a "foo"}
+ dde execute TclEval self [list set a foo]
dde request TclEval self a
-} foo
-test winDde-3.4 {DDE eval locally} {win dde} {
- set a ""
- dde eval self set a "foo"
-} foo
-test winDde-3.5 {DDE request locally} {win dde} {
+} -result foo
+test winDde-3.4 {DDE eval locally} -constraints dde -body {
+ set \xe1 ""
+ dde eval self set \xe1 foo
+} -result foo
+test winDde-3.5 {DDE request locally} -constraints dde -body {
set a ""
- dde execute TclEval self {set a "foo"}
+ dde execute TclEval self [list set a foo]
dde request -binary TclEval self a
-} "foo\x00"
+} -result "foo\x00"
+# Set variable a to A with diaeresis (unicode C4) by relying on the fact
+# that utf8 is sent (e.g. "c3 84" on the wire)
+test winDde-3.6 {DDE request utf8} -constraints dde -body {
+ set a "not set"
+ dde execute TclEval self "set a \xc4"
+ scan $a %c
+} -result 196
+# Set variable a to A with diaeresis (unicode C4) using binary execute
+# and compose utf-8 (e.g. "c3 84" ) manualy
+test winDde-3.7 {DDE request binary} -constraints dde -body {
+ set a "not set"
+ dde execute -binary TclEval self [list set a \xc3\x84\x00]
+ scan $a %c
+} -result 196
# -------------------------------------------------------------------------
-test winDde-4.1 {DDE execute remotely} {stdio win dde} {
- set a ""
- set name child-4.1
+test winDde-4.1 {DDE execute remotely} -constraints {dde stdio} -body {
+ set \xe1 ""
+ set name ch\xEDld-4.1
set child [createChildProcess $name]
- dde execute TclEval $name {set a "foo"}
+ dde execute TclEval $name [list set \xe1 foo]
dde execute TclEval $name {set done 1}
update
- set a
-} ""
-test winDde-4.2 {DDE execute async remotely} {stdio win dde} {
- set a ""
- set name child-4.2
+ set \xe1
+} -result ""
+test winDde-4.2 {DDE execute async remotely} -constraints {dde stdio} -body {
+ set \xe1 ""
+ set name ch\xEDld-4.2
set child [createChildProcess $name]
- dde execute -async TclEval $name {set a "foo"}
+ dde execute -async TclEval $name [list set \xe1 foo]
update
dde execute TclEval $name {set done 1}
update
- set a
-} ""
-test winDde-4.3 {DDE request remotely} {stdio win dde} {
+ set \xe1
+} -result ""
+test winDde-4.3 {DDE request remotely} -constraints {dde stdio} -body {
set a ""
- set name chile-4.3
+ set name ch\xEDld-4.3
set child [createChildProcess $name]
- dde execute TclEval $name {set a "foo"}
+ dde execute TclEval $name [list set a foo]
set a [dde request TclEval $name a]
dde execute TclEval $name {set done 1}
update
set a
-} foo
-test winDde-4.4 {DDE eval remotely} {stdio win dde} {
+} -result foo
+test winDde-4.4 {DDE eval remotely} -constraints {dde stdio} -body {
set a ""
- set name child-4.4
+ set name ch\xEDld-4.4
set child [createChildProcess $name]
- set a [dde eval $name set a "foo"]
+ set a [dde eval $name set a foo]
dde execute TclEval $name {set done 1}
update
set a
-} foo
+} -result foo
# -------------------------------------------------------------------------
-test winDde-5.1 {check for bad arguments} -constraints {win dde} -body {
+test winDde-5.1 {check for bad arguments} -constraints dde -body {
dde execute "" "" "" ""
-} -returnCodes error -result {wrong # args: should be "dde execute ?-async? serviceName topicName value"}
-test winDde-5.2 {check for bad arguments} -constraints {win dde} -body {
- dde execute "" "" ""
+} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"}
+test winDde-5.2 {check for bad arguments} -constraints dde -body {
+ dde execute -binary "" "" ""
} -returnCodes error -result {cannot execute null data}
-test winDde-5.3 {check for bad arguments} -constraints {win dde} -body {
+test winDde-5.3 {check for bad arguments} -constraints dde -body {
dde execute -foo "" "" ""
-} -returnCodes error -result {wrong # args: should be "dde execute ?-async? serviceName topicName value"}
-test winDde-5.4 {DDE eval bad arguments} -constraints {win dde} -body {
+} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"}
+test winDde-5.4 {DDE eval bad arguments} -constraints dde -body {
dde eval "" "foo"
} -returnCodes error -result {invalid service name ""}
# -------------------------------------------------------------------------
-test winDde-6.1 {DDE servername bad arguments} -constraints {win dde} -body {
+test winDde-6.1 {DDE servername bad arguments} -constraints dde -body {
dde servername -z -z -z
} -returnCodes error -result {bad option "-z": must be -force, -handler, or --}
-test winDde-6.2 {DDE servername set name} -constraints {win dde} -body {
+test winDde-6.2 {DDE servername set name} -constraints dde -body {
dde servername -- winDde-6.2
} -result {winDde-6.2}
-test winDde-6.3 {DDE servername set exact name} -constraints {win dde} -body {
+test winDde-6.3 {DDE servername set exact name} -constraints dde -body {
dde servername -force winDde-6.3
} -result {winDde-6.3}
-test winDde-6.4 {DDE servername set exact name} -constraints {win dde} -body {
+test winDde-6.4 {DDE servername set exact name} -constraints dde -body {
dde servername -force -- winDde-6.4
} -result {winDde-6.4}
-test winDde-6.5 {DDE remote servername collision} -constraints {stdio win dde} -setup {
- set name child-6.5
+test winDde-6.5 {DDE remote servername collision} -constraints {dde stdio} -setup {
+ set name ch\xEDld-6.5
set child [createChildProcess $name]
} -body {
dde servername -- $name
} -cleanup {
dde execute TclEval $name {set done 1}
update
-} -result "child-6.5 #2"
-test winDde-6.6 {DDE remote servername collision force} -constraints {stdio win dde} -setup {
- set name child-6.6
+} -result "ch\xEDld-6.5 #2"
+test winDde-6.6 {DDE remote servername collision force} -constraints {dde stdio} -setup {
+ set name ch\xEDld-6.6
set child [createChildProcess $name]
} -body {
dde servername -force -- $name
} -cleanup {
dde execute TclEval $name {set done 1}
update
-} -result {child-6.6}
+} -result "ch\xEDld-6.6"
# -------------------------------------------------------------------------
-test winDde-7.1 {Load DDE in slave interpreter } -constraints {win dde} -setup {
+test winDde-7.1 {Load DDE in slave interpreter} -constraints dde -setup {
interp create slave
} -body {
slave eval [list load $::ddelib Dde]
@@ -256,7 +267,7 @@ test winDde-7.1 {Load DDE in slave interpreter } -constraints {win dde} -setup {
} -cleanup {
interp delete slave
} -result {dde-interp-7.1}
-test winDde-7.2 {DDE slave cleanup} -constraints {win dde} -setup {
+test winDde-7.2 {DDE slave cleanup} -constraints dde -setup {
interp create slave
slave eval [list load $::ddelib Dde]
slave eval [list dde servername -- dde-interp-7.5]
@@ -269,7 +280,7 @@ test winDde-7.2 {DDE slave cleanup} -constraints {win dde} -setup {
set s
}
} -result {}
-test winDde-7.3 {DDE present in slave interp} -constraints {win dde} -setup {
+test winDde-7.3 {DDE present in slave interp} -constraints dde -setup {
interp create slave
slave eval [list load $::ddelib Dde]
slave eval [list dde servername -- dde-interp-7.3]
@@ -278,7 +289,7 @@ test winDde-7.3 {DDE present in slave interp} -constraints {win dde} -setup {
} -cleanup {
interp delete slave
} -result {{TclEval dde-interp-7.3}}
-test winDde-7.4 {interp name collision with -force} -constraints {win dde} -setup {
+test winDde-7.4 {interp name collision with -force} -constraints dde -setup {
interp create slave
slave eval [list load $::ddelib Dde]
slave eval [list dde servername -- dde-interp-7.4]
@@ -287,7 +298,7 @@ test winDde-7.4 {interp name collision with -force} -constraints {win dde} -setu
} -cleanup {
interp delete slave
} -result {dde-interp-7.4}
-test winDde-7.5 {interp name collision without -force} -constraints {win dde} -setup {
+test winDde-7.5 {interp name collision without -force} -constraints dde -setup {
interp create slave
slave eval [list load $::ddelib Dde]
slave eval [list dde servername -- dde-interp-7.5]
@@ -299,7 +310,7 @@ test winDde-7.5 {interp name collision without -force} -constraints {win dde} -s
# -------------------------------------------------------------------------
-test winDde-8.1 {Safe DDE load} -constraints {win dde} -setup {
+test winDde-8.1 {Safe DDE load} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
} -body {
@@ -307,20 +318,20 @@ test winDde-8.1 {Safe DDE load} -constraints {win dde} -setup {
} -cleanup {
interp delete slave
} -returnCodes error -result {invalid command name "dde"}
-test winDde-8.2 {Safe DDE set servername} -constraints {win dde} -setup {
+test winDde-8.2 {Safe DDE set servername} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
} -body {
slave invokehidden dde servername slave
} -cleanup {interp delete slave} -result {slave}
-test winDde-8.3 {Safe DDE check handler required for eval} -constraints {win dde} -setup {
+test winDde-8.3 {Safe DDE check handler required for eval} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
slave invokehidden dde servername slave
} -body {
catch {dde eval slave set a 1} msg
} -cleanup {interp delete slave} -result {1}
-test winDde-8.4 {Safe DDE check that execute is denied} -constraints {win dde} -setup {
+test winDde-8.4 {Safe DDE check that execute is denied} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
slave invokehidden dde servername slave
@@ -329,7 +340,7 @@ test winDde-8.4 {Safe DDE check that execute is denied} -constraints {win dde} -
dde execute TclEval slave {set a 2}
slave eval set a
} -cleanup {interp delete slave} -result 1
-test winDde-8.5 {Safe DDE check that request is denied} -constraints {win dde} -setup {
+test winDde-8.5 {Safe DDE check that request is denied} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
slave invokehidden dde servername slave
@@ -339,14 +350,14 @@ test winDde-8.5 {Safe DDE check that request is denied} -constraints {win dde} -
} -cleanup {
interp delete slave
} -returnCodes error -result {remote server cannot handle this command}
-test winDde-8.6 {Safe DDE assign handler procedure} -constraints {win dde} -setup {
+test winDde-8.6 {Safe DDE assign handler procedure} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
} -body {
slave invokehidden dde servername -handler DDEACCEPT slave
} -cleanup {interp delete slave} -result slave
-test winDde-8.7 {Safe DDE check simple command} -constraints {win dde} -setup {
+test winDde-8.7 {Safe DDE check simple command} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
@@ -354,7 +365,7 @@ test winDde-8.7 {Safe DDE check simple command} -constraints {win dde} -setup {
} -body {
dde eval slave set x 1
} -cleanup {interp delete slave} -result {set x 1}
-test winDde-8.8 {Safe DDE check non-list command} -constraints {win dde} -setup {
+test winDde-8.8 {Safe DDE check non-list command} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
@@ -364,16 +375,16 @@ test winDde-8.8 {Safe DDE check non-list command} -constraints {win dde} -setup
dde eval slave $s
string equal [slave eval set DDECMD] $s
} -cleanup {interp delete slave} -result 1
-test winDde-8.9 {Safe DDE check command evaluation} -constraints {win dde} -setup {
+test winDde-8.9 {Safe DDE check command evaluation} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
slave invokehidden dde servername -handler DDEACCEPT slave
} -body {
- dde eval slave set x 1
- slave eval set x
+ dde eval slave set \xe1 1
+ slave eval set \xe1
} -cleanup {interp delete slave} -result 1
-test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints {win dde} -setup {
+test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
@@ -382,7 +393,7 @@ test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints {win dde}
dde eval slave [list set x 1]
slave eval set x
} -cleanup {interp delete slave} -result 1
-test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints {win dde} -setup {
+test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints dde -setup {
interp create -safe slave
slave invokehidden load $::ddelib Dde
slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
@@ -394,9 +405,9 @@ test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints {win dde}
# -------------------------------------------------------------------------
-test winDde-9.1 {External safe DDE check string passing} -constraints {win dde stdio} -setup {
- set name child-9.1
- set child [createChildProcess $name Handler1]
+test winDde-9.1 {External safe DDE check string passing} -constraints {dde stdio} -setup {
+ set name ch\xEDld-9.1
+ set child [createChildProcess $name -handler Handler1]
file copy -force script1.tcl dde-script.tcl
} -body {
dde eval $name set x 1
@@ -407,9 +418,9 @@ test winDde-9.1 {External safe DDE check string passing} -constraints {win dde s
update
file delete -force -- dde-script.tcl
} -result {set x 1}
-test winDde-9.2 {External safe DDE check command evaluation} -constraints {win dde stdio} -setup {
- set name child-9.2
- set child [createChildProcess $name Handler2]
+test winDde-9.2 {External safe DDE check command evaluation} -constraints {dde stdio} -setup {
+ set name ch\xEDld-9.2
+ set child [createChildProcess $name -handler Handler2]
file copy -force script1.tcl dde-script.tcl
} -body {
dde eval $name set x 1
@@ -420,9 +431,9 @@ test winDde-9.2 {External safe DDE check command evaluation} -constraints {win d
update
file delete -force -- dde-script.tcl
} -result 1
-test winDde-9.3 {External safe DDE check prefixed arguments} -constraints {win dde stdio} -setup {
- set name child-9.3
- set child [createChildProcess $name [list Handler3 ARG]]
+test winDde-9.3 {External safe DDE check prefixed arguments} -constraints {dde stdio} -setup {
+ set name ch\xEDld-9.3
+ set child [createChildProcess $name -handler [list Handler3 ARG]]
file copy -force script1.tcl dde-script.tcl
} -body {
dde eval $name set x 1
@@ -433,6 +444,19 @@ test winDde-9.3 {External safe DDE check prefixed arguments} -constraints {win d
update
file delete -force -- dde-script.tcl
} -result {ARG {set x 1}}
+test winDde-9.4 {External safe DDE check null data passing} -constraints {dde stdio} -setup {
+ set name ch\xEDld-9.4
+ set child [createChildProcess $name -handler Handler1]
+ file copy -force script1.tcl dde-script.tcl
+} -body {
+ dde execute TclEval $name ""
+ gets $child line
+ set line
+} -cleanup {
+ dde execute TclEval $name stop
+ update
+ file delete -force -- dde-script.tcl
+} -result {null data}
# -------------------------------------------------------------------------
diff --git a/tests/zlib.test b/tests/zlib.test
index 3aaca29..8212082 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -103,6 +103,22 @@ test zlib-7.4 {zlib stream} zlib {
$s close
lappend result $data
} {{} 1 abcdeEDCBA}
+test zlib-7.5 {zlib stream} zlib {
+ set s [zlib stream gzip]
+ $s put -finalize abcdeEDCBA..
+ set data [$s get]
+ set result [list [$s get] [format %x [$s checksum]]]
+ $s close
+ lappend result [zlib gunzip $data]
+} {{} 69f34b6a abcdeEDCBA..}
+test zlib-7.6 {zlib stream} zlib {
+ set s [zlib stream gunzip]
+ $s put -finalize [zlib gzip abcdeEDCBA..]
+ set data [$s get]
+ set result [list [$s get] [format %x [$s checksum]]]
+ $s close
+ lappend result $data
+} {{} 69f34b6a abcdeEDCBA..}
test zlib-8.1 {zlib transformation} -constraints zlib -setup {
set file [makeFile {} test.gz]
@@ -147,6 +163,7 @@ test zlib-8.3 {zlib transformation and fileevent} -constraints zlib -setup {
set ::total [expr {$e eq {} ? $c : $e}]
}}}
vwait total
+ after cancel {set total timeout}
} finally {
close $sin
}
@@ -168,6 +185,24 @@ test zlib-8.4 {transformation and flushing: Bug 3517696} -setup {
catch {close $fd}
removeFile $file
} -result {}
+test zlib-8.5 {transformation and flushing and fileevents: Bug 3525907} -setup {
+ foreach {r w} [chan pipe] break
+} -constraints zlib -body {
+ set ::res {}
+ fconfigure $w -buffering none
+ zlib push compress $w
+ puts -nonewline $w qwertyuiop
+ chan configure $w -flush sync
+ after 500 {puts -nonewline $w asdfghjkl;close $w}
+ fconfigure $r -blocking 0 -buffering none
+ zlib push decompress $r
+ fileevent $r readable {set msg [read $r];lappend ::res $msg;if {[eof $r]} {set ::done 1}}
+ after 250 {lappend ::res MIDDLE}
+ vwait ::done
+ set ::res
+} -cleanup {
+ catch {close $r}
+} -result {qwertyuiop MIDDLE asdfghjkl}
test zlib-9.1 "check fcopy with push" -constraints zlib -setup {
set sfile [makeFile {} testsrc.gz]
@@ -226,6 +261,7 @@ test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup
set ::total [expr {$e eq {} ? $c : $e}]
}}}
vwait ::total
+ after cancel {set ::total timeout}
close $sin; close $fout
list read $::total size [file size $file]
} -cleanup {
@@ -251,6 +287,7 @@ test zlib-9.4 "socket fcopy bg (gzip)" -constraints zlib -setup {
set ::total [expr {$e eq {} ? $c : $e}]
}}}
vwait ::total
+ after cancel {set ::total timeout}
close $sin; close $fout
list read $::total size [file size $file]
} -cleanup {
@@ -284,6 +321,7 @@ test zlib-9.5 "socket fcopy incremental (gzip)" -constraints zlib -setup {
after 1000 {set ::total timeout}
fcopy $sin $fout -size 8192 -command [list zlib95copy $sin $fout 0]
vwait ::total
+ after cancel {set ::total timeout}
close $sin; close $fout
list $::total size [file size $file]
} -cleanup {
@@ -312,6 +350,7 @@ test zlib-9.6 "bug #2818131 (gzip)" -constraints zlib -setup {
}
}} $s]
vwait ::total
+ after cancel {set ::total timeout}
close $s
set ::total
} -cleanup {
@@ -339,6 +378,7 @@ test zlib-9.7 "bug #2818131 (compress)" -constraints zlib -setup {
}
}} $s]
vwait ::total
+ after cancel {set ::total timeout}
close $s
set ::total
} -cleanup {
@@ -366,6 +406,7 @@ test zlib-9.8 "bug #2818131 (deflate)" -constraints zlib -setup {
}
}} $s]
vwait ::total
+ after cancel {set ::total timeout}
close $s
set ::total
} -cleanup {
@@ -396,6 +437,7 @@ test zlib-9.9 "bug #2818131 (gzip mismatch)" -constraints zlib -setup {
}} $s]
vwait ::total
} finally {
+ after cancel {set ::total timeout}
close $s
}
set ::total
@@ -428,6 +470,7 @@ test zlib-9.10 "bug #2818131 (compress mismatch)" -constraints zlib -setup {
}} $s]
vwait ::total
} finally {
+ after cancel {set ::total timeout}
close $s
}
set ::total
@@ -460,6 +503,7 @@ test zlib-9.11 "bug #2818131 (deflate mismatch)" -constraints zlib -setup {
}} $s]
vwait ::total
} finally {
+ after cancel {set ::total timeout}
close $s
}
set ::total
@@ -502,6 +546,8 @@ test zlib-10.0 "bug #2818131 (close with null interp)" -constraints {
after 100 {set ::total done}
}} $s]
vwait ::total
+ after cancel {set ::total timeout}
+ after cancel {set ::total done}
set ::total
} -cleanup {
close $srv
@@ -538,6 +584,8 @@ test zlib-10.1 "bug #2818131 (mismatch read)" -constraints {
after 100 {set ::total done}
}} $s]
vwait ::total
+ after cancel {set ::total timeout}
+ after cancel {set ::total done}
set ::total
} -cleanup {
close $srv
@@ -576,6 +624,8 @@ test zlib-10.2 "bug #2818131 (mismatch gets)" -constraints {
after 100 {set ::total done}
}} $s]
vwait ::total
+ after cancel {set ::total timeout}
+ after cancel {set ::total done}
set ::total
} -cleanup {
close $srv
generated by cgit v0.12 at 2024-11-17 01:09:00 (GMT)