summaryrefslogtreecommitdiffstats
path: root/tests/ioCmd.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/ioCmd.test')
-rw-r--r--tests/ioCmd.test466
1 files changed, 310 insertions, 156 deletions
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 920238c..03242be 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -12,18 +12,19 @@
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: ioCmd.test,v 1.53 2010/08/03 20:06:47 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
# Custom constraints used in this file
testConstraint fcopy [llength [info commands fcopy]]
testConstraint testchannel [llength [info commands testchannel]]
-testConstraint testthread [llength [info commands testthread]]
+testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
#----------------------------------------------------------------------
@@ -35,7 +36,7 @@ test iocmd-1.2 {puts command} {
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.3 {puts command} {
list [catch {puts froboz -nonewline kablooie} msg] $msg
-} {1 {bad argument "kablooie": should be "nonewline"}}
+} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.4 {puts command} {
list [catch {puts froboz hello} msg] $msg
} {1 {can not find channel named "froboz"}}
@@ -138,7 +139,7 @@ test iocmd-4.8 {read command with incorrect combination of arguments} {
} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"} {TCL WRONGARGS}}
test iocmd-4.9 {read command} {
list [catch {read stdin foo} msg] $msg $::errorCode
-} {1 {bad argument "foo": should be "nonewline"} NONE}
+} {1 {expected non-negative integer but got "foo"} {TCL VALUE NUMBER}}
test iocmd-4.10 {read command} {
list [catch {read file107} msg] $msg $::errorCode
} {1 {can not find channel named "file107"} {TCL LOOKUP CHANNEL file107}}
@@ -156,7 +157,7 @@ test iocmd-4.12 {read command} -setup {
list [catch {read $f 12z} msg] $msg $::errorCode
} -cleanup {
close $f
-} -result {1 {expected integer but got "12z"} {TCL VALUE NUMBER}}
+} -result {1 {expected non-negative integer but got "12z"} {TCL VALUE NUMBER}}
test iocmd-5.1 {seek command} -returnCodes error -body {
seek
@@ -388,13 +389,13 @@ test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} {
set f [open $path(test4) w]
close $f
list [catch {open "| cat < \"$path(test4)\" > \"$path(test5)\"" w} msg] $msg $::errorCode
-} {1 {can't write input to command: standard input was redirected} NONE}
+} {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} {
list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode
-} {1 {can't read output from command: standard output was redirected} NONE}
+} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} {
list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode
-} {1 {can't read output from command: standard output was redirected} NONE}
+} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.4 {I/O to command pipelines} unixOrPc {
list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode
} {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}}
@@ -1993,7 +1994,6 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m
# response.
interp eval $idb [list set chan $chan]
- interp eval $idb [list set mid $tcltest::mainThread]
set res [interp eval $idb {
# wait a bit, give the main thread the time to start its event
# loop to wait for the response from B
@@ -2030,23 +2030,6 @@ test iocmd-32.2 {delete interp of reflected chan} {
## forwarding, and gaps due to tests not applicable to forwarding are
## left to keep this asociation.
-# 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
- }
-}
-
# ### ### ### ######### ######### #########
## Helper command. Runs a script in a separate thread and returns the
## result. A channel is transfered into the thread as well, and list of
@@ -2055,7 +2038,8 @@ if {[testConstraint testthread]} {
proc inthread {chan script args} {
# Test thread.
- set tid [testthread create]
+ set tid [thread::create -preserved]
+ thread::send $tid {load {} Tcltest}
# Init thread configuration.
# - Listed variables
@@ -2064,22 +2048,23 @@ proc inthread {chan script args} {
foreach v $args {
upvar 1 $v x
- testthread send $tid [list set $v $x]
+ thread::send $tid [list set $v $x]
+
}
- testthread send $tid [list set mid $tcltest::mainThread]
- testthread send $tid {
+ thread::send $tid [list set mid [thread::id]]
+ thread::send $tid {
proc note {item} {global notes; lappend notes $item}
proc notes {} {global notes; return $notes}
proc noteOpts opts {global notes; lappend notes [dict merge {
-code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?!
} $opts]}
}
- testthread send $tid [list proc s {} [list uplevel 1 $script]]; # (*)
+ thread::send $tid [list proc s {} [list uplevel 1 $script]]; # (*)
# Transfer channel (cut/splice aka detach/attach)
testchannel cut $chan
- testthread send $tid [list testchannel splice $chan]
+ thread::send $tid [list testchannel splice $chan]
# Run test script, also run local event loop!
# The local event loop waits for the result to come back.
@@ -2087,15 +2072,15 @@ proc inthread {chan script args} {
# operations.
set ::tres ""
- testthread send -async $tid {
+ thread::send -async $tid {
after 500
catch {s} res; # This runs the script, 's' was defined at (*)
- testthread send -async $mid [list set ::tres $res]
+ thread::send -async $mid [list set ::tres $res]
}
vwait ::tres
# Remove test thread, and return the captured result.
- tcltest::threadReap
+ thread::release $tid
return $::tres
}
@@ -2116,7 +2101,7 @@ test iocmd.tf-22.2 {chan finalize, for close} -match glob -body {
note [info command foo]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo}
+} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo}
test iocmd.tf-22.3 {chan finalize, for close, error, close error} -match glob -body {
set res {}
proc foo {args} {track; oninit; return -code error 5}
@@ -2129,7 +2114,7 @@ test iocmd.tf-22.3 {chan finalize, for close, error, close error} -match glob -b
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}}
+} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}}
test iocmd.tf-22.4 {chan finalize, for close, error, close errror} -match glob -body {
set res {}
proc foo {args} {track; oninit; error FOO}
@@ -2140,7 +2125,7 @@ test iocmd.tf-22.4 {chan finalize, for close, error, close errror} -match glob -
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO}
+} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO}
test iocmd.tf-22.5 {chan finalize, for close, arbitrary result} -match glob -body {
set res {}
proc foo {args} {track; oninit; return SOMETHING}
@@ -2151,7 +2136,7 @@ test iocmd.tf-22.5 {chan finalize, for close, arbitrary result} -match glob -bod
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}}
+} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}}
test iocmd.tf-22.6 {chan finalize, for close, break, close error} -match glob -body {
set res {}
proc foo {args} {track; oninit; return -code 3}
@@ -2163,7 +2148,7 @@ test iocmd.tf-22.6 {chan finalize, for close, break, close error} -match glob -b
rename foo {}
set res
} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-22.7 {chan finalize, for close, continue, close error} -match glob -body {
set res {}
proc foo {args} {track; oninit; return -code 4}
@@ -2175,7 +2160,7 @@ test iocmd.tf-22.7 {chan finalize, for close, continue, close error} -match glob
rename foo {}
set res
} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-22.8 {chan finalize, for close, custom code, close error} -match glob -body {
set res {}
proc foo {args} {track; oninit; return -code 777 BANG}
@@ -2187,7 +2172,7 @@ test iocmd.tf-22.8 {chan finalize, for close, custom code, close error} -match g
rename foo {}
set res
} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-22.9 {chan finalize, for close, ignore level, close error} -match glob -body {
set res {}
proc foo {args} {track; oninit; return -level 5 -code 777 BANG}
@@ -2199,7 +2184,7 @@ test iocmd.tf-22.9 {chan finalize, for close, ignore level, close error} -match
rename foo {}
set res
} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
# --- === *** ###########################
# method read
@@ -2218,7 +2203,7 @@ test iocmd.tf-23.1 {chan read, regular data return} -match glob -body {
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf}
+} -constraints {testchannel thread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf}
test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body {
set res {}
proc foo {args} {
@@ -2233,7 +2218,7 @@ test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body {
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{read rc* 4096} 1 {read delivered more than requested}}
+} -constraints {testchannel thread} -result {{read rc* 4096} 1 {read delivered more than requested}}
test iocmd.tf-23.3 {chan read, for non-readable channel} -match glob -body {
set res {}
proc foo {args} {
@@ -2247,7 +2232,7 @@ test iocmd.tf-23.3 {chan read, for non-readable channel} -match glob -body {
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for reading}}
+} -constraints {testchannel thread} -result {1 {channel "rc*" wasn't opened for reading}}
test iocmd.tf-23.4 {chan read, error return} -match glob -body {
set res {}
proc foo {args} {
@@ -2263,7 +2248,7 @@ test iocmd.tf-23.4 {chan read, error return} -match glob -body {
rename foo {}
set res
} -result {{read rc* 4096} 1 BOOM!} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-23.5 {chan read, break return is error} -match glob -body {
set res {}
proc foo {args} {
@@ -2279,7 +2264,7 @@ test iocmd.tf-23.5 {chan read, break return is error} -match glob -body {
rename foo {}
set res
} -result {{read rc* 4096} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-23.6 {chan read, continue return is error} -match glob -body {
set res {}
proc foo {args} {
@@ -2295,7 +2280,7 @@ test iocmd.tf-23.6 {chan read, continue return is error} -match glob -body {
rename foo {}
set res
} -result {{read rc* 4096} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-23.7 {chan read, custom return is error} -match glob -body {
set res {}
proc foo {args} {
@@ -2311,7 +2296,7 @@ test iocmd.tf-23.7 {chan read, custom return is error} -match glob -body {
rename foo {}
set res
} -result {{read rc* 4096} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body {
set res {}
proc foo {args} {
@@ -2327,7 +2312,7 @@ test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body {
rename foo {}
set res
} -result {{read rc* 4096} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-23.9 {chan read, no data means eof} -match glob -setup {
set res {}
proc foo {args} {
@@ -2347,7 +2332,7 @@ test iocmd.tf-23.9 {chan read, no data means eof} -match glob -setup {
rename foo {}
unset res
} -result {{read rc* 4096} {} 1} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glob -setup {
set res {}
proc foo {args} {
@@ -2367,7 +2352,7 @@ test iocmd.tf-23.10 {chan read, EAGAIN means no data, yet no eof either} -match
rename foo {}
unset res
} -result {{read rc* 4096} {} 0} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
# --- === *** ###########################
# method write
@@ -2387,7 +2372,7 @@ test iocmd.tf-24.1 {chan write, regular write} -match glob -body {
} c
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{write rc* snarf} 5}
+} -constraints {testchannel thread} -result {{write rc* snarf} 5}
test iocmd.tf-24.2 {chan write, ack partial writes} -match glob -body {
set res {}
proc foo {args} {
@@ -2404,7 +2389,7 @@ test iocmd.tf-24.2 {chan write, ack partial writes} -match glob -body {
} c
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8}
+} -constraints {testchannel thread} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8}
test iocmd.tf-24.3 {chan write, failed write} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; note -1; return -1}
@@ -2415,7 +2400,7 @@ test iocmd.tf-24.3 {chan write, failed write} -match glob -body {
} c
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} -1}
+} -constraints {testchannel thread} -result {{write rc* snarfsnarfsnarf} -1}
test iocmd.tf-24.4 {chan write, non-writable channel} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}
@@ -2428,7 +2413,7 @@ test iocmd.tf-24.4 {chan write, non-writable channel} -match glob -body {
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for writing}}
+} -constraints {testchannel thread} -result {1 {channel "rc*" wasn't opened for writing}}
test iocmd.tf-24.5 {chan write, bad result, more written than data} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return 10000}
@@ -2441,7 +2426,7 @@ test iocmd.tf-24.5 {chan write, bad result, more written than data} -match glob
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}}
+} -constraints {testchannel thread} -result {{write rc* snarf} 1 {write wrote more than requested}}
test iocmd.tf-24.6 {chan write, zero writes} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return 0}
@@ -2454,7 +2439,7 @@ test iocmd.tf-24.6 {chan write, zero writes} -match glob -body {
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}}
+} -constraints {testchannel thread} -result {{write rc* snarf} 1 {write wrote more than requested}}
test iocmd.tf-24.7 {chan write, failed write, error return} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return -code error BOOM!}
@@ -2468,7 +2453,7 @@ test iocmd.tf-24.7 {chan write, failed write, error return} -match glob -body {
rename foo {}
set res
} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-24.8 {chan write, failed write, error return} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; error BOOM!}
@@ -2482,7 +2467,7 @@ test iocmd.tf-24.8 {chan write, failed write, error return} -match glob -body {
rename foo {}
set res
} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-24.9 {chan write, failed write, break return is error} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return -code break BOOM!}
@@ -2496,7 +2481,7 @@ test iocmd.tf-24.9 {chan write, failed write, break return is error} -match glob
rename foo {}
set res
} -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-24.10 {chan write, failed write, continue return is error} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return -code continue BOOM!}
@@ -2510,7 +2495,7 @@ test iocmd.tf-24.10 {chan write, failed write, continue return is error} -match
rename foo {}
set res
} -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-24.11 {chan write, failed write, custom return is error} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!}
@@ -2524,7 +2509,7 @@ test iocmd.tf-24.11 {chan write, failed write, custom return is error} -match gl
rename foo {}
set res
} -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-24.12 {chan write, failed write, non-numeric return is error} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return BANG}
@@ -2538,7 +2523,7 @@ test iocmd.tf-24.12 {chan write, failed write, non-numeric return is error} -mat
rename foo {}
set res
} -result {{write rc* snarfsnarfsnarf} 1 {expected integer but got "BANG"}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-24.13 {chan write, failed write, level is ignored} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!}
@@ -2553,7 +2538,7 @@ test iocmd.tf-24.13 {chan write, failed write, level is ignored} -match glob -bo
rename foo {}
set res
} -result {{write rc* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-24.14 {chan write, no EAGAIN means that writing is allowed at this time, bug 2936225} -match glob -setup {
set res {}
proc foo {args} {
@@ -2572,7 +2557,7 @@ test iocmd.tf-24.14 {chan write, no EAGAIN means that writing is allowed at this
rename foo {}
unset res
} -result {{write rc* ABC} {}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at this time, bug 2936225} -match glob -setup {
set res {}
proc foo {args} {
@@ -2592,10 +2577,161 @@ test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at thi
} c]
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
} -result {{write rc* ABC} {watch rc* write} {}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
+
+test iocmd.tf-24.16 {chan write, note the background flush setup by close due to the EAGAIN leaving data in buffers.} -match glob -setup {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ # Note: The EAGAIN signals that the channel cannot accept
+ # write requests right now, this in turn causes the IO core to
+ # request the generation of writable events (see expected
+ # result below, and compare to case 24.14 above).
+ error EAGAIN
+ }
+ set c [chan create {r w} foo]
+} -body {
+ notes [inthread $c {
+ note [puts -nonewline $c ABC ; flush $c]
+ close $c
+ notes
+ } c]
+ # Replace handler with all-tracking one which doesn't error.
+ # This will tell us if a write-due-flush is there.
+ 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
@@ -2611,7 +2747,7 @@ test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} \
+} -constraints {testchannel thread} \
-result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}}
test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body {
set res {}
@@ -2624,7 +2760,7 @@ test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body {
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} \
+} -constraints {testchannel thread} \
-result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}}
test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body {
set res {}
@@ -2640,7 +2776,7 @@ test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body {
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} \
+} -constraints {testchannel thread} \
-result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}}
test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body {
set res {}
@@ -2657,7 +2793,7 @@ test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length}
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}}
+} -constraints {testchannel thread} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}}
test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob -body {
set res {}
proc foo {args} {
@@ -2673,7 +2809,7 @@ test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{cgetall rc*} 1 {unmatched open brace in list}}
+} -constraints {testchannel thread} -result {{cgetall rc*} 1 {unmatched open brace in list}}
test iocmd.tf-25.6 {chan configure, cgetall, error return} -match glob -body {
set res {}
proc foo {args} {
@@ -2689,7 +2825,7 @@ test iocmd.tf-25.6 {chan configure, cgetall, error return} -match glob -body {
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{cgetall rc*} 1 BOOM!}
+} -constraints {testchannel thread} -result {{cgetall rc*} 1 BOOM!}
test iocmd.tf-25.7 {chan configure, cgetall, break return is error} -match glob -body {
set res {}
proc foo {args} {
@@ -2706,7 +2842,7 @@ test iocmd.tf-25.7 {chan configure, cgetall, break return is error} -match glob
rename foo {}
set res
} -result {{cgetall rc*} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-25.8 {chan configure, cgetall, continue return is error} -match glob -body {
set res {}
proc foo {args} {
@@ -2723,7 +2859,7 @@ test iocmd.tf-25.8 {chan configure, cgetall, continue return is error} -match gl
rename foo {}
set res
} -result {{cgetall rc*} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-25.9 {chan configure, cgetall, custom return is error} -match glob -body {
set res {}
proc foo {args} {
@@ -2740,7 +2876,7 @@ test iocmd.tf-25.9 {chan configure, cgetall, custom return is error} -match glob
rename foo {}
set res
} -result {{cgetall rc*} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -body {
set res {}
proc foo {args} {
@@ -2758,7 +2894,7 @@ test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -bod
rename foo {}
set res
} -result {{cgetall rc*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "cgetall"*}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
# --- === *** ###########################
# method configure
@@ -2776,7 +2912,7 @@ test iocmd.tf-26.1 {chan configure, set standard option} -match glob -body {
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{}}
+} -constraints {testchannel thread} -result {{}}
test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body {
set res {}
proc foo {args} {
@@ -2792,7 +2928,7 @@ test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} 1 BOOM!}
+} -constraints {testchannel thread} -result {{configure rc* -rc-foo bar} 1 BOOM!}
test iocmd.tf-26.3 {chan configure, set option, ok return} -match glob -body {
set res {}
proc foo {args} {oninit configure; onfinal; track; return}
@@ -2804,7 +2940,7 @@ test iocmd.tf-26.3 {chan configure, set option, ok return} -match glob -body {
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} {}}
+} -constraints {testchannel thread} -result {{configure rc* -rc-foo bar} {}}
test iocmd.tf-26.4 {chan configure, set option, break return is error} -match glob -body {
set res {}
proc foo {args} {
@@ -2821,7 +2957,7 @@ test iocmd.tf-26.4 {chan configure, set option, break return is error} -match gl
rename foo {}
set res
} -result {{configure rc* -rc-foo bar} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-26.5 {chan configure, set option, continue return is error} -match glob -body {
set res {}
proc foo {args} {
@@ -2838,7 +2974,7 @@ test iocmd.tf-26.5 {chan configure, set option, continue return is error} -match
rename foo {}
set res
} -result {{configure rc* -rc-foo bar} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-26.6 {chan configure, set option, custom return is error} -match glob -body {
set res {}
proc foo {args} {
@@ -2855,7 +2991,7 @@ test iocmd.tf-26.6 {chan configure, set option, custom return is error} -match g
rename foo {}
set res
} -result {{configure rc* -rc-foo bar} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -body {
set res {}
proc foo {args} {
@@ -2873,7 +3009,7 @@ test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -b
rename foo {}
set res
} -result {{configure rc* -rc-foo bar} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "configure"*}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
# --- === *** ###########################
# method cget
@@ -2889,7 +3025,7 @@ test iocmd.tf-27.1 {chan configure, get option, ok return} -match glob -body {
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{cget rc* -rc-foo} foo}
+} -constraints {testchannel thread} -result {{cget rc* -rc-foo} foo}
test iocmd.tf-27.2 {chan configure, get option, error return} -match glob -body {
set res {}
proc foo {args} {
@@ -2905,7 +3041,7 @@ test iocmd.tf-27.2 {chan configure, get option, error return} -match glob -body
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{cget rc* -rc-foo} 1 BOOM!}
+} -constraints {testchannel thread} -result {{cget rc* -rc-foo} 1 BOOM!}
test iocmd.tf-27.3 {chan configure, get option, break return is error} -match glob -body {
set res {}
proc foo {args} {
@@ -2922,7 +3058,7 @@ test iocmd.tf-27.3 {chan configure, get option, break return is error} -match gl
rename foo {}
set res
} -result {{cget rc* -rc-foo} 1 BOOM!} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-27.4 {chan configure, get option, continue return is error} -match glob -body {
set res {}
proc foo {args} {
@@ -2939,7 +3075,7 @@ test iocmd.tf-27.4 {chan configure, get option, continue return is error} -match
rename foo {}
set res
} -result {{cget rc* -rc-foo} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-27.5 {chan configure, get option, custom return is error} -match glob -body {
set res {}
proc foo {args} {
@@ -2956,7 +3092,7 @@ test iocmd.tf-27.5 {chan configure, get option, custom return is error} -match g
rename foo {}
set res
} -result {{cget rc* -rc-foo} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -body {
set res {}
proc foo {args} {
@@ -2974,7 +3110,7 @@ test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -b
rename foo {}
set res
} -result {{cget rc* -rc-foo} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "cget"*}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
# --- === *** ###########################
# method seek
@@ -2991,7 +3127,7 @@ test iocmd.tf-28.1 {chan tell, not supported by handler} -match glob -body {
rename foo {}
set res
} -result {-1} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-28.2 {chan tell, error return} -match glob -body {
set res {}
proc foo {args} {oninit seek; onfinal; track; return -code error BOOM!}
@@ -3005,7 +3141,7 @@ test iocmd.tf-28.2 {chan tell, error return} -match glob -body {
rename foo {}
set res
} -result {{seek rc* 0 current} 1 BOOM!} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-28.3 {chan tell, break return is error} -match glob -body {
set res {}
proc foo {args} {oninit seek; onfinal; track; return -code break BOOM!}
@@ -3019,7 +3155,7 @@ test iocmd.tf-28.3 {chan tell, break return is error} -match glob -body {
rename foo {}
set res
} -result {{seek rc* 0 current} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-28.4 {chan tell, continue return is error} -match glob -body {
set res {}
proc foo {args} {oninit seek; onfinal; track; return -code continue BOOM!}
@@ -3033,7 +3169,7 @@ test iocmd.tf-28.4 {chan tell, continue return is error} -match glob -body {
rename foo {}
set res
} -result {{seek rc* 0 current} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-28.5 {chan tell, custom return is error} -match glob -body {
set res {}
proc foo {args} {oninit seek; onfinal; track; return -code 222 BOOM!}
@@ -3047,7 +3183,7 @@ test iocmd.tf-28.5 {chan tell, custom return is error} -match glob -body {
rename foo {}
set res
} -result {{seek rc* 0 current} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-28.6 {chan tell, level is ignored} -match glob -body {
set res {}
proc foo {args} {oninit seek; onfinal; track; return -level 11 -code 222 BANG}
@@ -3062,7 +3198,7 @@ test iocmd.tf-28.6 {chan tell, level is ignored} -match glob -body {
rename foo {}
set res
} -result {{seek rc* 0 current} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "seek"*}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-28.7 {chan tell, regular return} -match glob -body {
set res {}
proc foo {args} {oninit seek; onfinal; track; return 88}
@@ -3075,7 +3211,7 @@ test iocmd.tf-28.7 {chan tell, regular return} -match glob -body {
rename foo {}
set res
} -result {{seek rc* 0 current} 88} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-28.8 {chan tell, negative return} -match glob -body {
set res {}
proc foo {args} {oninit seek; onfinal; track; return -1}
@@ -3089,7 +3225,7 @@ test iocmd.tf-28.8 {chan tell, negative return} -match glob -body {
rename foo {}
set res
} -result {{seek rc* 0 current} 1 {Tried to seek before origin}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-28.9 {chan tell, string return} -match glob -body {
set res {}
proc foo {args} {oninit seek; onfinal; track; return BOGUS}
@@ -3103,7 +3239,7 @@ test iocmd.tf-28.9 {chan tell, string return} -match glob -body {
rename foo {}
set res
} -result {{seek rc* 0 current} 1 {expected integer but got "BOGUS"}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-28.10 {chan seek, not supported by handler} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}
@@ -3117,7 +3253,7 @@ test iocmd.tf-28.10 {chan seek, not supported by handler} -match glob -body {
rename foo {}
set res
} -result {1 {error during seek on "rc*": invalid argument}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-28.11 {chan seek, error return} -match glob -body {
set res {}
proc foo {args} {oninit seek; onfinal; track; return -code error BOOM!}
@@ -3131,7 +3267,7 @@ test iocmd.tf-28.11 {chan seek, error return} -match glob -body {
rename foo {}
set res
} -result {{seek rc* 0 start} 1 BOOM!} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-28.12 {chan seek, break return is error} -match glob -body {
set res {}
proc foo {args} {oninit seek; onfinal; track; return -code break BOOM!}
@@ -3145,7 +3281,7 @@ test iocmd.tf-28.12 {chan seek, break return is error} -match glob -body {
rename foo {}
set res
} -result {{seek rc* 0 start} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-28.13 {chan seek, continue return is error} -match glob -body {
set res {}
proc foo {args} {oninit seek; onfinal; track; return -code continue BOOM!}
@@ -3159,7 +3295,7 @@ test iocmd.tf-28.13 {chan seek, continue return is error} -match glob -body {
rename foo {}
set res
} -result {{seek rc* 0 start} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-28.14 {chan seek, custom return is error} -match glob -body {
set res {}
proc foo {args} {oninit seek; onfinal; track; return -code 99 BOOM!}
@@ -3173,7 +3309,7 @@ test iocmd.tf-28.14 {chan seek, custom return is error} -match glob -body {
rename foo {}
set res
} -result {{seek rc* 0 start} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-28.15 {chan seek, level is ignored} -match glob -body {
set res {}
proc foo {args} {oninit seek; onfinal; track; return -level 33 -code 99 BANG}
@@ -3188,7 +3324,7 @@ test iocmd.tf-28.15 {chan seek, level is ignored} -match glob -body {
rename foo {}
set res
} -result {{seek rc* 0 start} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "seek"*}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-28.16 {chan seek, bogus return, negative location} -match glob -body {
set res {}
proc foo {args} {oninit seek; onfinal; track; return -45}
@@ -3202,7 +3338,7 @@ test iocmd.tf-28.16 {chan seek, bogus return, negative location} -match glob -bo
rename foo {}
set res
} -result {{seek rc* 0 start} 1 {Tried to seek before origin}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-28.17 {chan seek, bogus return, string return} -match glob -body {
set res {}
proc foo {args} {oninit seek; onfinal; track; return BOGUS}
@@ -3216,7 +3352,7 @@ test iocmd.tf-28.17 {chan seek, bogus return, string return} -match glob -body {
rename foo {}
set res
} -result {{seek rc* 0 start} 1 {expected integer but got "BOGUS"}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-28.18 {chan seek, ok result} -match glob -body {
set res {}
proc foo {args} {oninit seek; onfinal; track; return 23}
@@ -3229,7 +3365,7 @@ test iocmd.tf-28.18 {chan seek, ok result} -match glob -body {
rename foo {}
set res
} -result {{seek rc* 0 current} {}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
foreach {testname code} {
iocmd.tf-28.19.0 start
iocmd.tf-28.19.1 current
@@ -3247,7 +3383,7 @@ foreach {testname code} {
rename foo {}
set res
} -result [list [list seek rc* 0 $code] {}] \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
}
# --- === *** ###########################
@@ -3265,7 +3401,7 @@ test iocmd.tf-29.1 {chan blocking, no handler support} -match glob -body {
rename foo {}
set res
} -result {1} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-29.2 {chan blocking, no handler support} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}
@@ -3279,7 +3415,7 @@ test iocmd.tf-29.2 {chan blocking, no handler support} -match glob -body {
rename foo {}
set res
} -result {{} 0} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-29.3 {chan blocking, retrieval, handler support} -match glob -body {
set res {}
proc foo {args} {oninit blocking; onfinal; track; note MUST_NOT_HAPPEN; return}
@@ -3292,7 +3428,7 @@ test iocmd.tf-29.3 {chan blocking, retrieval, handler support} -match glob -body
rename foo {}
set res
} -result {1} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-29.4 {chan blocking, resetting, handler support} -match glob -body {
set res {}
proc foo {args} {oninit blocking; onfinal; track; return}
@@ -3306,7 +3442,7 @@ test iocmd.tf-29.4 {chan blocking, resetting, handler support} -match glob -body
rename foo {}
set res
} -result {{blocking rc* 0} {} 0} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-29.5 {chan blocking, setting, handler support} -match glob -body {
set res {}
proc foo {args} {oninit blocking; onfinal; track; return}
@@ -3320,7 +3456,7 @@ test iocmd.tf-29.5 {chan blocking, setting, handler support} -match glob -body {
rename foo {}
set res
} -result {{blocking rc* 1} {} 1} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-29.6 {chan blocking, error return} -match glob -body {
set res {}
proc foo {args} {oninit blocking; onfinal; track; error BOOM!}
@@ -3335,7 +3471,7 @@ test iocmd.tf-29.6 {chan blocking, error return} -match glob -body {
rename foo {}
set res
} -result {{blocking rc* 0} 1 BOOM!} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-29.7 {chan blocking, break return is error} -match glob -body {
set res {}
proc foo {args} {oninit blocking; onfinal; track; return -code break BOOM!}
@@ -3349,7 +3485,7 @@ test iocmd.tf-29.7 {chan blocking, break return is error} -match glob -body {
rename foo {}
set res
} -result {{blocking rc* 0} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-29.8 {chan blocking, continue return is error} -match glob -body {
set res {}
proc foo {args} {oninit blocking; onfinal; track; return -code continue BOOM!}
@@ -3363,7 +3499,7 @@ test iocmd.tf-29.8 {chan blocking, continue return is error} -match glob -body {
rename foo {}
set res
} -result {{blocking rc* 0} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-29.9 {chan blocking, custom return is error} -match glob -body {
set res {}
proc foo {args} {oninit blocking; onfinal; track; return -code 44 BOOM!}
@@ -3377,7 +3513,7 @@ test iocmd.tf-29.9 {chan blocking, custom return is error} -match glob -body {
rename foo {}
set res
} -result {{blocking rc* 0} 1 *bad code*} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body {
set res {}
proc foo {args} {oninit blocking; onfinal; track; return -level 99 -code 44 BANG}
@@ -3392,7 +3528,7 @@ test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body {
rename foo {}
set res
} -result {{blocking rc* 0} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "blocking"*}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
test iocmd.tf-29.11 {chan blocking, regular return ok, value ignored} -match glob -body {
set res {}
proc foo {args} {oninit blocking; onfinal; track; return BOGUS}
@@ -3406,7 +3542,7 @@ test iocmd.tf-29.11 {chan blocking, regular return ok, value ignored} -match glo
rename foo {}
set res
} -result {{blocking rc* 0} 0 {}} \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
# --- === *** ###########################
# method watch
@@ -3422,7 +3558,7 @@ test iocmd.tf-30.1 {chan watch, read interest, some return} -match glob -body {
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{watch rc* read} {watch rc* {}} {}}
+} -constraints {testchannel thread} -result {{watch rc* read} {watch rc* {}} {}}
test iocmd.tf-30.2 {chan watch, write interest, error return} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return -code error BOOM!_IGNORED}
@@ -3435,7 +3571,7 @@ test iocmd.tf-30.2 {chan watch, write interest, error return} -match glob -body
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} -result {{watch rc* write} {watch rc* {}} {} {}}
+} -constraints {testchannel thread} -result {{watch rc* write} {watch rc* {}} {} {}}
test iocmd.tf-30.3 {chan watch, accumulated interests} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return}
@@ -3450,7 +3586,7 @@ test iocmd.tf-30.3 {chan watch, accumulated interests} -match glob -body {
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} \
+} -constraints {testchannel thread} \
-result {{watch rc* write} {watch rc* {read write}} {watch rc* read} {watch rc* {}} {} {} {} {}}
test iocmd.tf-30.4 {chan watch, unchanged interest not forwarded} -match glob -body {
set res {}
@@ -3465,7 +3601,7 @@ test iocmd.tf-30.4 {chan watch, unchanged interest not forwarded} -match glob -b
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} \
+} -constraints {testchannel thread} \
-result {{watch rc* write} {watch rc* {read write}} {watch rc* write} {watch rc* {}} {} {} {}}
# --- === *** ###########################
@@ -3485,7 +3621,7 @@ test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body {
} c]
rename foo {}
set res
-} -constraints {testchannel testthread} \
+} -constraints {testchannel thread} \
-result {{can not find reflected channel named "rc*"}}
# --- === *** ###########################
@@ -3496,12 +3632,15 @@ test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body {
test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body {
#puts <<$tcltest::mainThread>>main
- set tida [testthread create];#puts <<$tida>>
- set tidb [testthread create];#puts <<$tidb>>
+ set tida [thread::create -preserved];#puts <<$tida>>
+ thread::send $tida {load {} Tcltest}
+
+ set tidb [thread::create -preserved];#puts <<$tidb>>
+ thread::send $tidb {load {} Tcltest}
# Set up channel in thread
- testthread send $tida $helperscript
- set chan [testthread send $tida {
+ thread::send $tida $helperscript
+ set chan [thread::send $tida {
proc foo {args} {oninit seek; onfinal; track; return}
set chan [chan create {r w} foo]
fconfigure $chan -buffering none
@@ -3509,67 +3648,82 @@ test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body {
}]
# Move channel to 2nd thread.
- testthread send $tida [list testchannel cut $chan]
- testthread send $tidb [list testchannel splice $chan]
+ thread::send $tida [list testchannel cut $chan]
+ thread::send $tidb [list testchannel splice $chan]
# Kill origin thread, then access channel from 2nd thread.
- testthread send -async $tida {testthread exit}
- after 100
+ thread::release $tida
set res {}
- lappend res [catch {testthread send $tidb [list puts $chan shoo]} msg] $msg
+ lappend res [catch {thread::send $tidb [list puts $chan shoo]} msg] $msg
- lappend res [catch {testthread send $tidb [list tell $chan]} msg] $msg
- lappend res [catch {testthread send $tidb [list seek $chan 1]} msg] $msg
- lappend res [catch {testthread send $tidb [list gets $chan]} msg] $msg
- lappend res [catch {testthread send $tidb [list close $chan]} msg] $msg
- tcltest::threadReap
+ lappend res [catch {thread::send $tidb [list tell $chan]} msg] $msg
+ lappend res [catch {thread::send $tidb [list seek $chan 1]} msg] $msg
+ lappend res [catch {thread::send $tidb [list gets $chan]} msg] $msg
+ lappend res [catch {thread::send $tidb [list close $chan]} msg] $msg
+ thread::release $tidb
set res
-} -constraints {testchannel testthread} \
+} -constraints {testchannel thread} \
-result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
+
+# The test iocmd.tf-32.1 unavoidably exhibits a memory leak. We are testing
+# the ability of the reflected channel system to react to the situation where
+# the thread in which the driver routines runs exits during driver operations.
+# In this case, thread exit handlers signal back to the owner thread so that the
+# channel operation does not hang. There's no way to test this without actually
+# exiting a thread in mid-operation, and that action is unavoidably leaky (which
+# is why [thread::exit] is advised against).
+#
+# Use constraints to skip this test while valgrinding so this expected leak
+# doesn't prevent a finding of "leak-free".
+#
+testConstraint notValgrind [expr {![testConstraint valgrind]}]
test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -match glob -body {
#puts <<$tcltest::mainThread>>main
- set tida [testthread create];#puts <<$tida>>
- set tidb [testthread create];#puts <<$tidb>>
+ set tida [thread::create -preserved];#puts <<$tida>>
+ thread::send $tida {load {} Tcltest}
+ set tidb [thread::create -preserved];#puts <<$tidb>>
+ thread::send $tidb {load {} Tcltest}
# Set up channel in thread
- set chan [testthread send $tida $helperscript]
- set chan [testthread send $tida {
+ thread::send $tida $helperscript
+ set chan [thread::send $tida {
proc foo {args} {
oninit; onfinal; track;
# destroy thread during channel access
- testthread exit
- return}
+ thread::exit
+ }
set chan [chan create {r w} foo]
fconfigure $chan -buffering none
set chan
}]
# Move channel to 2nd thread.
- testthread send $tida [list testchannel cut $chan]
- testthread send $tidb [list testchannel splice $chan]
+ thread::send $tida [list testchannel cut $chan]
+ thread::send $tidb [list testchannel splice $chan]
# Run access from thread B, wait for response from A (A is not
# using event loop at this point, so the event pile up in the
# queue.
- testthread send $tidb [list set chan $chan]
- testthread send $tidb [list set mid $tcltest::mainThread]
- testthread send -async $tidb {
+ thread::send $tidb [list set chan $chan]
+ thread::send $tidb [list set mid [thread::id]]
+ thread::send -async $tidb {
# wait a bit, give the main thread the time to start its event
# loop to wait for the response from B
after 2000
catch { puts $chan shoo } res
- testthread send -async $mid [list set ::res $res]
+ thread::send -async $mid [list set ::res $res]
}
vwait ::res
- tcltest::threadReap
+ catch {thread::release $tida}
+ thread::release $tidb
set res
-} -constraints {testchannel testthread} \
+} -constraints {testchannel thread notValgrind} \
-result {Owner lost}
# ### ### ### ######### ######### #########
generated by cgit v0.12 at 2024-08-20 15:23:24 (GMT)