diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/http.test | 26 | ||||
| -rw-r--r-- | tests/httpd | 8 | ||||
| -rw-r--r-- | tests/oo.test | 142 | ||||
| -rw-r--r-- | tests/reg.test | 15 | ||||
| -rw-r--r-- | tests/socket.test | 30 | ||||
| -rw-r--r-- | tests/thread.test | 186 | ||||
| -rw-r--r-- | tests/unixNotfy.test | 13 | ||||
| -rw-r--r-- | tests/utf.test | 14 |
8 files changed, 300 insertions, 134 deletions
diff --git a/tests/http.test b/tests/http.test index e6e7649..d9c1efb 100644 --- a/tests/http.test +++ b/tests/http.test @@ -364,6 +364,32 @@ test http-3.26 {http::meta} -setup { http::cleanup $token unset -nocomplain m token } -result {Content-Length Content-Type Date X-Check} +test http-3.27 {http::geturl: -headers override -type} -body { + set token [http::geturl $url/headers -type "text/plain" -query dummy \ + -headers [list "Content-Type" "text/plain;charset=utf-8"]] + http::data $token +} -cleanup { + http::cleanup $token +} -match regexp -result {(?n)Accept \*/\* +Host .* +User-Agent .* +Connection close +Content-Type {text/plain;charset=utf-8} +Accept-Encoding .* +Content-Length 5} +test http-3.28 {http::geturl: -headers override -type default} -body { + set token [http::geturl $url/headers -query dummy \ + -headers [list "Content-Type" "text/plain;charset=utf-8"]] + http::data $token +} -cleanup { + http::cleanup $token +} -match regexp -result {(?n)Accept \*/\* +Host .* +User-Agent .* +Connection close +Content-Type {text/plain;charset=utf-8} +Accept-Encoding .* +Content-Length 5} test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] diff --git a/tests/httpd b/tests/httpd index 5272385..f810797 100644 --- a/tests/httpd +++ b/tests/httpd @@ -175,6 +175,14 @@ proc httpdRespond { sock } { set html "Got [string length $data(query)] bytes" set type text/plain } + *headers* { + set html "" + set type text/plain + foreach {key value} $data(meta) { + append html [list $key $value] "\n" + } + set html [string trim $html] + } default { set type text/html diff --git a/tests/oo.test b/tests/oo.test index b12cb42..e5a17f1 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -748,6 +748,148 @@ 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 +} -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-6.18 {Bug 3408830: more forwarding cases} -setup { + oo::class create fooClass +} -body { + oo::define fooClass { + forward len string length + } + [fooClass create foo] len a b +} -returnCodes error -cleanup { + fooClass destroy +} -result {wrong # args: should be "::foo len string"} test oo-7.1 {OO: inheritance 101} -setup { oo::class create superClass diff --git a/tests/reg.test b/tests/reg.test index d92339f..ca6cdd1 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -626,16 +626,24 @@ expectMatch 13.13 P "a\\nb" "a\nb" "a\nb" expectMatch 13.14 P "a\\rb" "a\rb" "a\rb" expectMatch 13.15 P "a\\tb" "a\tb" "a\tb" expectMatch 13.16 P "a\\u0008x" "a\bx" "a\bx" -expectError 13.17 - {a\u008x} EESCAPE +expectMatch 13.17 P {a\u008x} "a\bx" "a\bx" expectMatch 13.18 P "a\\u00088x" "a\b8x" "a\b8x" expectMatch 13.19 P "a\\U00000008x" "a\bx" "a\bx" -expectError 13.20 - {a\U0000008x} EESCAPE +expectMatch 13.20 P {a\U0000008x} "a\bx" "a\bx" expectMatch 13.21 P "a\\vb" "a\vb" "a\vb" expectMatch 13.22 MP "a\\x08x" "a\bx" "a\bx" expectError 13.23 - {a\xq} EESCAPE -expectMatch 13.24 MP "a\\x0008x" "a\bx" "a\bx" +expectMatch 13.24 MP "a\\x08x" "a\bx" "a\bx" expectError 13.25 - {a\z} EESCAPE expectMatch 13.26 MP "a\\010b" "a\bb" "a\bb" +expectMatch 13.27 P "a\\U00001234x" "a\u1234x" "a\u1234x" +expectMatch 13.28 P {a\U00001234x} "a\u1234x" "a\u1234x" +expectMatch 13.29 P "a\\U0001234x" "a\u1234x" "a\u1234x" +expectMatch 13.30 P {a\U0001234x} "a\u1234x" "a\u1234x" +expectMatch 13.31 P "a\\U000012345x" "a\u12345x" "a\u12345x" +expectMatch 13.32 P {a\U000012345x} "a\u12345x" "a\u12345x" +expectMatch 13.33 P "a\\U1000000x" "a\ufffd0x" "a\ufffd0x" +expectMatch 13.34 P {a\U1000000x} "a\ufffd0x" "a\ufffd0x" doing 14 "back references" @@ -682,6 +690,7 @@ expectError 15.9 - {a((((((((((b\10))))))))))c} ESUBREG expectMatch 15.10 MP "a\\12b" "a\nb" "a\nb" expectError 15.11 b {a\12b} ESUBREG expectMatch 15.12 eAS {a\12b} a12b a12b +expectMatch 15.13 MP {a\701b} a\u00381b a\u00381b doing 16 "expanded syntax" diff --git a/tests/socket.test b/tests/socket.test index 0ea0eb5..f63f5ca 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] # ---------------------------------------------------------------------- @@ -1769,6 +1760,7 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \ set client [socket -async localhost $port] fileevent $client writable { lappend x [fconfigure $client -error] + fileevent $client writable {} } set after [after 1000 {lappend x timeout}] while {[llength $x] < 2 && "timeout" ni $x} { 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..2a17098 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,15 @@ 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}" + thread::create "thread::send [thread::id] {set x ok}" vwait x - threadReap set x } \ -result {ok} \ @@ -79,7 +79,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 +90,8 @@ test unixNotfy-2.2 {Tcl_DeleteFileHandler} \ close $f1 vwait y close $f2 - testthread create "testthread send [testthread id] {set x ok}" + thread::create "thread::send [thread::id] {set x ok}" vwait x - threadReap set x } \ -result {ok} \ diff --git a/tests/utf.test b/tests/utf.test index 3bf7b06..64b5cd4 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -171,7 +171,7 @@ bsCheck \x 120 bsCheck \xa 10 bsCheck \xA 10 bsCheck \x41 65 -bsCheck \x541 65 +bsCheck \x541 84 bsCheck \u 117 bsCheck \uk 117 bsCheck \u41 65 @@ -180,6 +180,18 @@ bsCheck \uA 10 bsCheck \340 224 bsCheck \ua1 161 bsCheck \u4e21 20001 +bsCheck \741 60 +bsCheck \U 85 +bsCheck \Uk 85 +bsCheck \U41 65 +bsCheck \Ua 10 +bsCheck \UA 10 +bsCheck \Ua1 161 +bsCheck \U4e21 20001 +bsCheck \U004e21 20001 +bsCheck \U00004e21 20001 +bsCheck \U00110000 65533 +bsCheck \Uffffffff 65533 test utf-11.1 {Tcl_UtfToUpper} { string toupper {} |