summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/binary.test17
-rw-r--r--tests/chanio.test28
-rw-r--r--tests/http.test19
-rw-r--r--tests/interp.test12
-rw-r--r--tests/io.test33
-rw-r--r--tests/oo.test132
-rw-r--r--tests/parseExpr.test66
-rw-r--r--tests/scan.test4
-rw-r--r--tests/socket.test29
-rw-r--r--tests/thread.test186
-rw-r--r--tests/unixNotfy.test15
11 files changed, 349 insertions, 192 deletions
diff --git a/tests/binary.test b/tests/binary.test
index 8b2880b..6c00508 100644
--- a/tests/binary.test
+++ b/tests/binary.test
@@ -2381,6 +2381,23 @@ test binary-63.4 {NaN} ieeeFloatingPoint {
format 0x%016lx [expr {$w & 0xfff3ffffffffffff}]
} 0x7ff3123456789abc
+# Make sure TclParseNumber() rejects invalid nan-hex formats [Bug 3402540]
+test binary-63.5 {NaN} -constraints ieeeFloatingPoint -body {
+ binary format q Nan(
+} -returnCodes error -match glob -result {expected floating-point number*}
+test binary-63.6 {NaN} -constraints ieeeFloatingPoint -body {
+ binary format q Nan()
+} -returnCodes error -match glob -result {expected floating-point number*}
+test binary-63.7 {NaN} -constraints ieeeFloatingPoint -body {
+ binary format q Nan(g)
+} -returnCodes error -match glob -result {expected floating-point number*}
+test binary-63.8 {NaN} -constraints ieeeFloatingPoint -body {
+ binary format q Nan(1,2)
+} -returnCodes error -match glob -result {expected floating-point number*}
+test binary-63.9 {NaN} -constraints ieeeFloatingPoint -body {
+ binary format q Nan(1234567890abcd)
+} -returnCodes error -match glob -result {expected floating-point number*}
+
test binary-64.1 {NaN} -constraints ieeeFloatingPoint -body {
binary scan [binary format w 0x7ff8000000000000] q d
set d
diff --git a/tests/chanio.test b/tests/chanio.test
index 5569385..fbc9854 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -37,7 +37,7 @@ namespace eval ::tcl::test::io {
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
- testConstraint testthread [llength [info commands testthread]]
+ testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
# You need a *very* special environment to do some tests. In particular,
# many file systems do not support large-files...
@@ -7413,7 +7413,6 @@ test chan-io-59.1 {Thread reference of channels} {testmainthread testchannel} {
# More complicated tests (like that the reference changes as a channel is
# moved from thread to thread) can be done only in the extension which
# fully implements the moving of channels between threads, i.e. 'Threads'.
- # Or we have to extend [testthread] as well.
set f [open $path(longfile) r]
set result [testchannel mthread $f]
chan close $f
@@ -7494,37 +7493,26 @@ test chan-io-70.0 {Cutting & Splicing channels} -setup {
chan close $c
removeFile cutsplice
} -result {0 1 0}
-# Duplicate of code in "thread.test". Find a better way of doing this without
-# duplication. Maybe placement into a proc which transforms to nop after the
-# first call, and placement of its defintion in a central location.
-if {[testConstraint testthread]} {
- testthread errorproc ThreadError
- proc ThreadError {id info} {
- global threadError
- set threadError $info
- }
- proc ThreadNullError {id info} {
- # ignore
- }
-}
+
test chan-io-70.1 {Transfer channel} -setup {
set f [makeFile {... dummy ...} cutsplice]
set res {}
-} -constraints {testchannel testthread} -body {
+} -constraints {testchannel thread} -body {
set c [open $f r]
lappend res [catch {chan seek $c 0 start}]
testchannel cut $c
lappend res [catch {chan seek $c 0 start}]
- set tid [testthread create]
- testthread send $tid [list set c $c]
- lappend res [testthread send $tid {
+ set tid [thread::create -preserved]
+ thread::send $tid [list set c $c]
+ thread::send $tid {load {} Tcltest}
+ lappend res [thread::send $tid {
testchannel splice $c
set res [catch {chan seek $c 0 start}]
chan close $c
set res
}]
} -cleanup {
- tcltest::threadReap
+ thread::release $tid
removeFile cutsplice
} -result {0 1 0}
diff --git a/tests/http.test b/tests/http.test
index 1f4d8b4..e6e7649 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -51,14 +51,13 @@ if {![file exists $httpdFile]} {
set removeHttpd 1
}
-if {[info commands testthread] == "testthread" && [file exists $httpdFile]} {
- set httpthread [testthread create "
- source [list $httpdFile]
- testthread wait
- "]
- testthread send $httpthread [list set port $port]
- testthread send $httpthread [list set bindata $bindata]
- testthread send $httpthread {httpd_init $port}
+catch {package require Thread 2.6}
+if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} {
+ set httpthread [thread::create -preserved]
+ thread::send $httpthread [list source $httpdFile]
+ thread::send $httpthread [list set port $port]
+ thread::send $httpthread [list set bindata $bindata]
+ thread::send $httpthread {httpd_init $port}
puts "Running httpd in thread $httpthread"
} else {
if {![file exists $httpdFile]} {
@@ -590,9 +589,7 @@ catch {unset badurl}
catch {unset port}
catch {unset data}
if {[info exists httpthread]} {
- testthread send -async $httpthread {
- testthread exit
- }
+ thread::release $httpthread
} else {
close $listen
}
diff --git a/tests/interp.test b/tests/interp.test
index 35f6824..c146355 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -584,7 +584,6 @@ test interp-14.10 {testing interp-alias: error messages} -setup {
invoked from within
"a 1"}
-
# part 15: testing file sharing
test interp-15.1 {testing file sharing} {
catch {interp delete z}
@@ -665,8 +664,7 @@ test interp-15.8 {testing file transferring} -body {
# Torture tests for interpreter deletion order
#
proc kill {} {interp delete xxx}
-
-test interp-15.9 {testing deletion order} {
+test interp-16.0 {testing deletion order} {
catch {interp delete xxx}
interp create xxx
xxx alias kill kill
@@ -3497,6 +3495,13 @@ test interp-35.22 {interp time limits normalize milliseconds} -body {
} -cleanup {
interp delete $i
} -result {2 500}
+# Bug 3398794
+test interp-35.23 {interp command limits can't touch current interp} -body {
+ interp limit {} commands -value 10
+} -returnCodes error -result {limits on current interpreter inaccessible}
+test interp-35.24 {interp time limits can't touch current interp} -body {
+ interp limit {} time -seconds 2
+} -returnCodes error -result {limits on current interpreter inaccessible}
test interp-36.1 {interp bgerror syntax} -body {
interp bgerror
@@ -3610,7 +3615,6 @@ test interp-38.8 {interp debug basic setup} -body {
} -returnCodes {
error
} -result {wrong # args: should be "interp debug path ?-frame ?bool??"}
-
# cleanup
unset -nocomplain hidden_cmds
diff --git a/tests/io.test b/tests/io.test
index e28948f..8a7cc51 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -37,7 +37,7 @@ testConstraint fcopy [llength [info commands fcopy]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
-testConstraint testthread [llength [info commands testthread]]
+testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
@@ -7435,7 +7435,7 @@ test io-59.1 {Thread reference of channels} {testmainthread testchannel} {
# More complicated tests (like that the reference changes as a
# channel is moved from thread to thread) can be done only in the
# extension which fully implements the moving of channels between
- # threads, i.e. 'Threads'. Or we have to extend [testthread] as well.
+ # threads, i.e. 'Threads'.
set f [open $path(longfile) r]
set result [testchannel mthread $f]
@@ -7527,25 +7527,7 @@ test io-70.0 {Cutting & Splicing channels} {testchannel} {
} {0 1 0}
-# Duplicate of code in "thread.test". Find a better way of doing this
-# without duplication. Maybe placement into a proc which transforms to
-# nop after the first call, and placement of its defintion in a
-# central location.
-
-if {[testConstraint testthread]} {
- testthread errorproc ThreadError
-
- proc ThreadError {id info} {
- global threadError
- set threadError $info
- }
-
- proc ThreadNullError {id info} {
- # ignore
- }
-}
-
-test io-70.1 {Transfer channel} {testchannel testthread} {
+test io-70.1 {Transfer channel} {testchannel thread} {
set f [makeFile {... dummy ...} cutsplice]
set c [open $f r]
@@ -7554,16 +7536,17 @@ test io-70.1 {Transfer channel} {testchannel testthread} {
testchannel cut $c
lappend res [catch {seek $c 0 start}]
- set tid [testthread create]
- testthread send $tid [list set c $c]
- lappend res [testthread send $tid {
+ set tid [thread::create -preserved]
+ thread::send $tid [list set c $c]
+ thread::send $tid {load {} Tcltest}
+ lappend res [thread::send $tid {
testchannel splice $c
set res [catch {seek $c 0 start}]
close $c
set res
}]
- tcltest::threadReap
+ thread::release $tid
removeFile cutsplice
set res
diff --git a/tests/oo.test b/tests/oo.test
index b12cb42..5ec5d2f 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -748,6 +748,138 @@ test oo-6.7 {OO: forward resolution scope is per-object} -setup {
} -cleanup {
fooClass destroy
} -result 1
+test oo-6.8 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler
+ method handler {a b c} {}
+ }
+ fooClass create ::foo
+ foo test
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.9 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler
+ method handler {a b c} {list $a,$b,$c}
+ }
+ fooClass create ::foo
+ foo test 1 2 3
+} -cleanup {
+ fooClass destroy
+} -result 1,2,3
+test oo-6.10 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler
+ method handler {a b c} {list $a,$b,$c}
+ }
+ fooClass create ::foo
+ foo test 1 2
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.11 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::object create foo
+} -body {
+ oo::objdefine foo {
+ forward test my handler
+ method handler {a b c} {}
+ }
+ foo test
+} -returnCodes error -cleanup {
+ foo destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.12 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::object create foo
+} -body {
+ oo::objdefine foo {
+ forward test my handler
+ method handler {a b c} {list $a,$b,$c}
+ }
+ foo test 1 2 3
+} -cleanup {
+ foo destroy
+} -result 1,2,3
+test oo-6.13 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::object create foo
+} -body {
+ oo::objdefine foo {
+ forward test my handler
+ method handler {a b c} {list $a,$b,$c}
+ }
+ foo test 1 2
+} -returnCodes error -cleanup {
+ foo destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.14 {Bug 3400658: forwarding and wrongargs rewriting - multistep} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler1 p
+ forward handler1 my handler q
+ method handler {a b c} {}
+ }
+ fooClass create ::foo
+ foo test
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "foo test c"}
+test oo-6.15 {Bug 3400658: forwarding and wrongargs rewriting - multistep} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler1 p
+ forward handler1 my handler q
+ method handler {a b c} {list $a,$b,$c}
+ }
+ fooClass create ::foo
+ foo test 1
+} -cleanup {
+ fooClass destroy
+} -result q,p,1
+test oo-6.16 {Bug 3400658: forwarding and wrongargs rewriting - via alias} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test handler1 foo bar
+ forward handler2 my handler x
+ method handler {a b c d} {list $a,$b,$c,$d}
+ export eval
+ }
+ fooClass create ::foo
+ foo eval {
+ interp alias {} [namespace current]::handler1 \
+ {} [namespace current]::my handler2
+ }
+ foo test 1 2 3
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "foo test d"}
+test oo-6.17 {Bug 3400658: forwarding and wrongargs rewriting - via ensemble} -setup {
+ oo::class create fooClass
+} -constraints knownBug -body {
+ oo::define fooClass {
+ forward test handler1 foo bar boo
+ forward handler2 my handler
+ method handler {a b c d} {list $a,$b,$c,$d}
+ export eval
+ }
+ fooClass create ::foo
+ foo eval {
+ namespace ensemble create \
+ -command [namespace current]::handler1 -parameters {p q} \
+ -map [list boo [list [namespace current]::my handler2]]
+ }
+ foo test 1 2 3
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "foo test c d"}
test oo-7.1 {OO: inheritance 101} -setup {
oo::class create superClass
diff --git a/tests/parseExpr.test b/tests/parseExpr.test
index 7673dbe..cd0342a 100644
--- a/tests/parseExpr.test
+++ b/tests/parseExpr.test
@@ -997,6 +997,72 @@ test parseExpr-21.63 {error message} -body {
} -returnCodes error -result "missing close-brace
in expression \"...12345678901234567890*\[\{abcdefghijklmnopqrstuv...\""
+test parseExpr-22.1 {Bug 3401704} -constraints testexprparser -body {
+ testexprparser 2a() 1
+} -result {- {} 0 subexpr 2 1 text 2 0 {}}
+test parseExpr-22.2 {Bug 3401704} -constraints testexprparser -body {
+ testexprparser nana() 3
+} -result {- {} 0 subexpr nan 1 text nan 0 {}}
+test parseExpr-22.3 {Bug 3401704} -constraints testexprparser -body {
+ testexprparser 2a() -1
+} -result {- {} 0 subexpr 2a() 1 operator 2a 0 {}}
+test parseExpr-22.4 {Bug 3401704} -constraints testexprparser -body {
+ testexprparser nana() -1
+} -result {- {} 0 subexpr nana() 1 operator nana 0 {}}
+test parseExpr-22.5 {Bug 3401704} -constraints testexprparser -body {
+ testexprparser nan9() -1
+} -result {- {} 0 subexpr nan9() 1 operator nan9 0 {}}
+test parseExpr-22.6 {Bug 3401704} -constraints testexprparser -body {
+ testexprparser 2_() -1
+} -result {- {} 0 subexpr 2_() 1 operator 2_ 0 {}}
+test parseExpr-22.7 {Bug 3401704} -constraints testexprparser -body {
+ testexprparser nan_() -1
+} -result {- {} 0 subexpr nan_() 1 operator nan_ 0 {}}
+test parseExpr-22.8 {Bug 3401704} -constraints testexprparser -body {
+ catch {testexprparser nan!() -1} m o
+ dict get $o -errorcode
+} -result {TCL PARSE EXPR MISSING}
+test parseExpr-22.9 {Bug 3401704} -constraints testexprparser -body {
+ testexprparser 1e3_() -1
+} -result {- {} 0 subexpr 1e3_() 1 operator 1e3_ 0 {}}
+test parseExpr-22.10 {Bug 3401704} -constraints testexprparser -body {
+ catch {testexprparser 1.3_() -1} m o
+ dict get $o -errorcode
+} -result {TCL PARSE EXPR BADCHAR}
+test parseExpr-22.11 {Bug 3401704} -constraints testexprparser -body {
+ catch {testexprparser 1e-3_() -1} m o
+ dict get $o -errorcode
+} -result {TCL PARSE EXPR BADCHAR}
+test parseExpr-22.12 {Bug 3401704} -constraints testexprparser -body {
+ catch {testexprparser naneq() -1} m o
+ dict get $o -errorcode
+} -result {TCL PARSE EXPR EMPTY}
+test parseExpr-22.13 {Bug 3401704} -constraints testexprparser -body {
+ testexprparser naner() -1
+} -result {- {} 0 subexpr naner() 1 operator naner 0 {}}
+
+test parseExpr-22.14 {Bug 3401704} -constraints testexprparser -body {
+ catch {testexprparser 08 -1} m o
+ dict get $o -errorcode
+} -result {TCL PARSE EXPR BADNUMBER OCTAL}
+test parseExpr-22.15 {Bug 3401704} -constraints testexprparser -body {
+ catch {testexprparser 0o8 -1} m o
+ dict get $o -errorcode
+} -result {TCL PARSE EXPR BADNUMBER OCTAL}
+test parseExpr-22.16 {Bug 3401704} -constraints testexprparser -body {
+ catch {testexprparser 0o08 -1} m o
+ dict get $o -errorcode
+} -result {TCL PARSE EXPR BADNUMBER OCTAL}
+test parseExpr-22.17 {Bug 3401704} -constraints testexprparser -body {
+ catch {testexprparser 0b2 -1} m o
+ dict get $o -errorcode
+} -result {TCL PARSE EXPR BADNUMBER BINARY}
+test parseExpr-22.18 {Bug 3401704} -constraints testexprparser -body {
+ catch {testexprparser 0b02 -1} m o
+ dict get $o -errorcode
+} -result {TCL PARSE EXPR BADNUMBER BINARY}
+
+
# cleanup
::tcltest::cleanupTests
return
diff --git a/tests/scan.test b/tests/scan.test
index 84f22b4..97ad5eb 100644
--- a/tests/scan.test
+++ b/tests/scan.test
@@ -753,11 +753,11 @@ testConstraint ieeeFloatingPoint [testIEEE]
# scan infinities - not working
-test scan-14.1 {infinity} ieeeFloatingPoint {
+test scan-14.1 {infinity} {
scan Inf %g d
set d
} Inf
-test scan-14.2 {infinity} ieeeFloatingPoint {
+test scan-14.2 {infinity} {
scan -Inf %g d
set d
} -Inf
diff --git a/tests/socket.test b/tests/socket.test
index 0ea0eb5..58eb3ee 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -63,8 +63,8 @@
package require tcltest 2
namespace import -force ::tcltest::*
-# Some tests require the testthread and exec commands
-testConstraint testthread [llength [info commands testthread]]
+# Some tests require the Thread package or exec command
+testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
testConstraint exec [llength [info commands exec]]
# Produce a random port number in the Dynamic/Private range
@@ -1672,9 +1672,9 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup {
catch {close $p}
} -result {accepted socket was not inherited}
-test socket_$af-13.1 {Testing use of shared socket between two threads} -setup {
- threadReap
- set path(script) [makeFile [string map [list @localhost@ $localhost] {
+test socket_$af-13.1 {Testing use of shared socket between two threads} -body {
+ # create a thread
+ set serverthread [thread::create -preserved [string map [list @localhost@ $localhost] {
set f [socket -server accept -myaddr @localhost@ 0]
set listen [lindex [fconfigure $f -sockname] 2]
proc accept {s a p} {
@@ -1696,15 +1696,8 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -setup {
set i 0
vwait x
close $f
- # thread cleans itself up.
- testthread exit
- }] script]
-} -constraints [list socket supported_$af testthread] -body {
- # create a thread
- set serverthread [testthread create [list source $path(script) ] ]
- update
- set port [testthread send $serverthread {set listen}]
- update
+ }]]
+ set port [thread::send $serverthread {set listen}]
set s [socket $localhost $port]
fconfigure $s -buffering line
catch {
@@ -1712,11 +1705,9 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -setup {
gets $s result
}
close $s
- update
- append result " " [threadReap]
-} -cleanup {
- removeFile script
-} -result {hello 1}
+ thread::release $serverthread
+ append result " " [llength [thread::names]]
+} -result {hello 1} -constraints [list socket supported_$af thread]
# ----------------------------------------------------------------------
diff --git a/tests/thread.test b/tests/thread.test
index a6961ed..6cd4b5d 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -19,6 +19,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
# Some tests require the testthread command
testConstraint testthread [expr {[info commands testthread] != {}}]
+testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
if {[testConstraint testthread]} {
testthread errorproc ThreadError
@@ -41,40 +42,34 @@ test thread-1.1 {Tcl_ThreadObjCmd: no args} {testthread} {
test thread-1.2 {Tcl_ThreadObjCmd: bad option} {testthread} {
list [catch {testthread foo} msg] $msg
} {1 {bad option "foo": must be cancel, create, event, exit, id, join, names, send, wait, or errorproc}}
-test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {testthread} {
- list [threadReap] [llength [testthread names]]
-} {1 1}
-test thread-1.4 {Tcl_ThreadObjCmd: thread create } {testthread} {
- threadReap
- set serverthread [testthread create]
- update
- set numthreads [llength [testthread names]]
- threadReap
+test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {thread} {
+ llength [thread::names]
+} 1
+test thread-1.4 {Tcl_ThreadObjCmd: thread create } {thread} {
+ set serverthread [thread::create -preserved]
+ set numthreads [llength [thread::names]]
+ thread::release $serverthread
set numthreads
} {2}
-test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {testthread} {
- threadReap
- testthread create {set x 5}
+test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {thread} {
+ thread::create {set x 5}
foreach try {0 1 2 4 5 6} {
# Try various ways to yield
update
after 10
- set l [llength [testthread names]]
+ set l [llength [thread::names]]
if {$l == 1} {
break
}
}
- threadReap
set l
} {1}
-test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {testthread} {
+test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} {
threadReap
- testthread create {testthread exit}
+ thread::create {{*}{}}
update
after 10
- set result [llength [testthread names]]
- threadReap
- set result
+ llength [thread::names]
} {1}
test thread-1.7 {Tcl_ThreadObjCmd: thread id args} {testthread} {
set x [catch {testthread id x} msg]
@@ -98,11 +93,10 @@ test thread-1.12 {Tcl_ThreadObjCmd: send nonint} {testthread} {
set x [catch {testthread send abc command} msg]
list $x $msg
} {1 {expected integer but got "abc"}}
-test thread-1.13 {Tcl_ThreadObjCmd: send args} {testthread} {
- threadReap
- set serverthread [testthread create]
- set five [testthread send $serverthread {set x 5}]
- threadReap
+test thread-1.13 {Tcl_ThreadObjCmd: send args} {thread} {
+ set serverthread [thread::create -preserved]
+ set five [thread::send $serverthread {set x 5}]
+ thread::release $serverthread
set five
} 5
test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {testthread} {
@@ -110,11 +104,10 @@ test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {testthread} {
set x [catch {testthread send $tid {set x 5}} msg]
list $x $msg
} {1 {invalid thread id}}
-test thread-1.15 {Tcl_ThreadObjCmd: wait} {testthread} {
- threadReap
- set serverthread [testthread create {set z 5 ; testthread wait}]
- set five [testthread send $serverthread {set z}]
- threadReap
+test thread-1.15 {Tcl_ThreadObjCmd: wait} {thread} {
+ set serverthread [thread::create -preserved {set z 5 ; thread::wait}]
+ set five [thread::send $serverthread {set z}]
+ thread::release $serverthread
set five
} 5
test thread-1.16 {Tcl_ThreadObjCmd: errorproc args} {testthread} {
@@ -131,130 +124,115 @@ test thread-1.17 {Tcl_ThreadObjCmd: errorproc change} {testthread} {
# NewThread, safe and regular
# ThreadErrorProc, except for printing to standard error
-test thread-2.1 {ListUpdateInner and ListRemove} {testthread} {
- threadReap
+test thread-2.1 {ListUpdateInner and ListRemove} {thread} {
catch {unset tid}
foreach t {0 1 2} {
upvar #0 t$t tid
- set tid [testthread create]
+ set tid [thread::create -preserved]
}
- threadReap
+ foreach t {0 1 2} {
+ upvar #0 t$t tid
+ thread::release $tid
+ }
+ llength [thread::names]
} 1
-test thread-3.1 {TclThreadList} {testthread} {
- threadReap
+test thread-3.1 {TclThreadList} {thread} {
catch {unset tid}
- set len [llength [testthread names]]
+ set len [llength [thread::names]]
set l1 {}
foreach t {0 1 2} {
- lappend l1 [testthread create]
+ lappend l1 [thread::create -preserved]
+ }
+ set l2 [thread::names]
+ set c [string compare [lsort [concat [thread::id] $l1]] [lsort $l2]]
+ foreach t $l1 {
+ thread::release $t
}
- set l2 [testthread names]
- list $l1 $l2
- set c [string compare \
- [lsort -integer [concat $::tcltest::mainThread $l1]] \
- [lsort -integer $l2]]
- threadReap
list $len $c
} {1 0}
-test thread-4.1 {TclThreadSend to self} {testthread} {
+test thread-4.1 {TclThreadSend to self} {thread} {
catch {unset x}
- testthread send [testthread id] {
+ thread::send [thread::id] {
set x 4
}
set x
} {4}
-test thread-4.2 {TclThreadSend -async} {testthread} {
- threadReap
- set len [llength [testthread names]]
- set serverthread [testthread create]
- testthread send -async $serverthread {
- after 1000
- testthread exit
+test thread-4.2 {TclThreadSend -async} {thread} {
+ set len [llength [thread::names]]
+ set serverthread [thread::create -preserved]
+ thread::send -async $serverthread {
+ after 1 {thread::release}
}
- set two [llength [testthread names]]
- after 1500 {set done 1}
+ set two [llength [thread::names]]
+ after 100 {set done 1}
vwait done
- threadReap
- list $len [llength [testthread names]] $two
+ list $len [llength [thread::names]] $two
} {1 1 2}
-test thread-4.3 {TclThreadSend preserve errorInfo} {testthread} {
- threadReap
- set len [llength [testthread names]]
- set serverthread [testthread create]
- set x [catch {testthread send $serverthread {set undef}} msg]
+test thread-4.3 {TclThreadSend preserve errorInfo} {thread} {
+ set len [llength [thread::names]]
+ set serverthread [thread::create -preserved]
+ set x [catch {thread::send $serverthread {set undef}} msg]
set savedErrorInfo $::errorInfo
- threadReap
+ thread::release $serverthread
list $len $x $msg $savedErrorInfo
} {1 1 {can't read "undef": no such variable} {can't read "undef": no such variable
while executing
"set undef"
invoked from within
-"testthread send $serverthread {set undef}"}}
-test thread-4.4 {TclThreadSend preserve code} {testthread} {
- threadReap
- set len [llength [testthread names]]
- set serverthread [testthread create]
+"thread::send $serverthread {set undef}"}}
+test thread-4.4 {TclThreadSend preserve code} {thread} {
+ set len [llength [thread::names]]
+ set serverthread [thread::create -preserved]
set ::errorInfo {}
- set x [catch {testthread send $serverthread {set ::errorInfo {}; break}} msg]
+ set x [catch {thread::send $serverthread {set ::errorInfo {}; break}} msg]
set savedErrorInfo $::errorInfo
- threadReap
+ thread::release $serverthread
list $len $x $msg $savedErrorInfo
} {1 3 {} {}}
-test thread-4.5 {TclThreadSend preserve errorCode} {testthread} {
- threadReap
- set ::tcltest::mainThread [testthread names]
- set serverthread [testthread create]
- set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg]
+test thread-4.5 {TclThreadSend preserve errorCode} {thread} {
+ set serverthread [thread::create]
+ set x [catch {thread::send $serverthread {error ERR INFO CODE}} msg]
set savedErrorCode $::errorCode
- threadReap
+ thread::release $serverthread
list $x $msg $savedErrorCode
} {1 ERR CODE}
-test thread-5.0 {Joining threads} {testthread} {
- threadReap
- set serverthread [testthread create -joinable]
- testthread send -async $serverthread {after 1000 ; testthread exit}
- set res [testthread join $serverthread]
- threadReap
- set res
+test thread-5.0 {Joining threads} {thread} {
+ set serverthread [thread::create -joinable -preserved]
+ thread::send -async $serverthread {after 1000 ; thread::release}
+ thread::join $serverthread
} {0}
-test thread-5.1 {Joining threads after the fact} {testthread} {
- threadReap
- set serverthread [testthread create -joinable]
- testthread send -async $serverthread {testthread exit}
+test thread-5.1 {Joining threads after the fact} {thread} {
+ set serverthread [thread::create -joinable -preserved]
+ thread::send -async $serverthread {thread::release}
after 2000
- set res [testthread join $serverthread]
- threadReap
- set res
+ thread::join $serverthread
} {0}
-test thread-5.2 {Try to join a detached thread} {testthread} {
- threadReap
- set serverthread [testthread create]
- testthread send -async $serverthread {after 1000 ; testthread exit}
- catch {set res [testthread join $serverthread]} msg
- threadReap
+test thread-5.2 {Try to join a detached thread} {thread} {
+ set serverthread [thread::create -preserved]
+ thread::send -async $serverthread {after 1000 ; thread::release}
+ catch {set res [thread::join $serverthread]} msg
+ while {[llength [thread::names]] > 1} {
+ after 20
+ }
lrange $msg 0 2
} {cannot join thread}
-test thread-6.1 {freeing very large object trees in a thread} testthread {
+test thread-6.1 {freeing very large object trees in a thread} thread {
# conceptual duplicate of obj-32.1
- threadReap
- set serverthread [testthread create -joinable]
- testthread send -async $serverthread {
+ set serverthread [thread::create -preserved]
+ thread::send -async $serverthread {
set x {}
for {set i 0} {$i<100000} {incr i} {
set x [list $x {}]
}
unset x
- testthread exit
}
- catch {set res [testthread join $serverthread]} msg
- threadReap
- set res
-} {0}
+ thread::release -wait $serverthread
+} 0
# TIP #285: Script cancellation support
test thread-7.1 {cancel: args} {testthread} {
diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test
index 8af8a21..9684bfe 100644
--- a/tests/unixNotfy.test
+++ b/tests/unixNotfy.test
@@ -20,7 +20,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
}
# When run in a Tk shell, these tests hang.
-testConstraint noTk [expr {![info exists tk_version]}]
+testConstraint noTk [expr {0 != [catch {package present Tk}]}]
+testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
testConstraint testthread [expr {[info commands testthread] != {}}]
# Darwin always uses a threaded notifier
testConstraint unthreaded [expr {
@@ -61,16 +62,16 @@ test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -
}
test unixNotfy-2.1 {Tcl_DeleteFileHandler} \
- -constraints {noTk unix testthread} \
+ -constraints {noTk unix thread} \
-body {
update
set f [open [makeFile "" foo] w]
fileevent $f writable {set x 1}
vwait x
close $f
- testthread create "testthread send [testthread id] {set x ok}"
+ set t [thread::create -preserved "thread::send [thread::id] {set x ok}"]
vwait x
- threadReap
+ thread::release $t
set x
} \
-result {ok} \
@@ -79,7 +80,7 @@ test unixNotfy-2.1 {Tcl_DeleteFileHandler} \
catch { removeFile foo }
}
test unixNotfy-2.2 {Tcl_DeleteFileHandler} \
- -constraints {noTk unix testthread} \
+ -constraints {noTk unix thread} \
-body {
update
set f1 [open [makeFile "" foo] w]
@@ -90,9 +91,9 @@ test unixNotfy-2.2 {Tcl_DeleteFileHandler} \
close $f1
vwait y
close $f2
- testthread create "testthread send [testthread id] {set x ok}"
+ set t [thread::create -preserved "thread::send [thread::id] {set x ok}"]
vwait x
- threadReap
+ thread::release $t
set x
} \
-result {ok} \
generated by cgit v0.12 at 2024-11-23 17:11:45 (GMT)