summaryrefslogtreecommitdiffstats
path: root/tests/ioCmd.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/ioCmd.test')
-rw-r--r--tests/ioCmd.test593
1 files changed, 393 insertions, 200 deletions
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index e2a6d84..cd89a02 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -18,10 +18,13 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
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-}]}]
#----------------------------------------------------------------------
@@ -133,10 +136,10 @@ test iocmd-4.8 {read command with incorrect combination of arguments} {
set x [list [catch {read -nonewline $f 20 z} msg] $msg $::errorCode]
close $f
set x
-} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"} NONE}
+} {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 {expected integer but got "foo"} {TCL VALUE NUMBER}}
+} {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}}
@@ -148,25 +151,26 @@ test iocmd-4.11 {read command} {
string compare [string tolower $x] \
[list 1 [format "channel \"%s\" wasn't opened for reading" $f] none]
} 0
-test iocmd-4.12 {read command} {
+test iocmd-4.12 {read command} -setup {
set f [open $path(test1)]
- set x [list [catch {read $f 12z} msg] $msg $::errorCode]
+} -body {
+ list [catch {read $f 12z} msg] $msg $::errorCode
+} -cleanup {
close $f
- set x
-} {1 {expected integer but got "12z"} {TCL VALUE NUMBER}}
-
-test iocmd-5.1 {seek command} {
- list [catch {seek} msg] $msg
-} {1 {wrong # args: should be "seek channelId offset ?origin?"}}
-test iocmd-5.2 {seek command} {
- list [catch {seek a b c d e f g} msg] $msg
-} {1 {wrong # args: should be "seek channelId offset ?origin?"}}
-test iocmd-5.3 {seek command} {
- list [catch {seek stdin gugu} msg] $msg
-} {1 {expected integer but got "gugu"}}
-test iocmd-5.4 {seek command} {
- list [catch {seek stdin 100 gugu} msg] $msg
-} {1 {bad origin "gugu": must be start, current, or end}}
+} -result {1 {expected non-negative integer but got "12z"} {TCL VALUE NUMBER}}
+
+test iocmd-5.1 {seek command} -returnCodes error -body {
+ seek
+} -result {wrong # args: should be "seek channelId offset ?origin?"}
+test iocmd-5.2 {seek command} -returnCodes error -body {
+ seek a b c d e f g
+} -result {wrong # args: should be "seek channelId offset ?origin?"}
+test iocmd-5.3 {seek command} -returnCodes error -body {
+ seek stdin gugu
+} -result {expected integer but got "gugu"}
+test iocmd-5.4 {seek command} -returnCodes error -body {
+ seek stdin 100 gugu
+} -result {bad origin "gugu": must be start, current, or end}
test iocmd-6.1 {tell command} {
list [catch {tell} msg] $msg
@@ -180,20 +184,34 @@ test iocmd-6.3 {tell command} {
test iocmd-7.1 {close command} {
list [catch {close} msg] $msg
-} {1 {wrong # args: should be "close channelId"}}
+} {1 {wrong # args: should be "close channelId ?direction?"}}
test iocmd-7.2 {close command} {
list [catch {close a b c d e} msg] $msg
-} {1 {wrong # args: should be "close channelId"}}
+} {1 {wrong # args: should be "close channelId ?direction?"}}
test iocmd-7.3 {close command} {
list [catch {close aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
+test iocmd-7.4 {close command} -setup {
+ set chan [open [info script] r]
+} -body {
+ chan close $chan bar
+} -cleanup {
+ close $chan
+} -returnCodes error -result "bad direction \"bar\": must be read or write"
+test iocmd-7.5 {close command} -setup {
+ set chan [open [info script] r]
+} -body {
+ chan close $chan write
+} -cleanup {
+ close $chan
+} -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed"
test iocmd-8.1 {fconfigure command} {
list [catch {fconfigure} msg] $msg
-} {1 {wrong # args: should be "fconfigure channelId ?optionName? ?value? ?optionName value?..."}}
+} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}}
test iocmd-8.2 {fconfigure command} {
list [catch {fconfigure a b c d e f} msg] $msg
-} {1 {wrong # args: should be "fconfigure channelId ?optionName? ?value? ?optionName value?..."}}
+} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}}
test iocmd-8.3 {fconfigure command} {
list [catch {fconfigure a b} msg] $msg
} {1 {can not find channel named "a"}}
@@ -276,7 +294,7 @@ test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOr
close $srv
unset cli srv port
rename iocmdSRV {}
-} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -peername, or -sockname}
+} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -connecting, -peername, or -sockname}
test iocmd-8.16 {fconfigure command / tcp channel} -constraints socket -setup {
set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $srv -sockname] 2]
@@ -331,15 +349,15 @@ test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable
close $tty
}
} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -mode, -handshake, -pollinterval, -sysbuffer, -timeout, -ttycontrol, or -xchar}
-# TODO: Test parsing of serial channel options (nonportable, since requires an
+# TODO: Test parsing of serial channel options (nonPortable, since requires an
# open channel to work with).
test iocmd-9.1 {eof command} {
list [catch {eof} msg] $msg $::errorCode
-} {1 {wrong # args: should be "eof channelId"} NONE}
+} {1 {wrong # args: should be "eof channelId"} {TCL WRONGARGS}}
test iocmd-9.2 {eof command} {
list [catch {eof a b} msg] $msg $::errorCode
-} {1 {wrong # args: should be "eof channelId"} NONE}
+} {1 {wrong # args: should be "eof channelId"} {TCL WRONGARGS}}
test iocmd-9.3 {eof command} {
catch {close file100}
list [catch {eof file100} msg] $msg $::errorCode
@@ -371,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}}}
@@ -527,6 +545,27 @@ test iocmd-13.10.2 {open for append, O_APPEND} -setup {
# Ensure that channels are gone, even if body failed to do so
foreach ch $chans {catch {close $ch}}
} -result {0 1 2 3 4 5 6 7 8 9}
+test ioCmd-13.11 {open ... a+ must not use O_APPEND: Bug 1773127} -setup {
+ set f [makeFile {} ioutil41.tmp]
+ set fid [open $f wb]
+ puts -nonewline $fid 123
+ close $fid
+} -body {
+ set fid [open $f ab+]
+ puts -nonewline $fid 456
+ seek $fid 2
+ set d [read $fid 2]
+ seek $fid 4
+ puts -nonewline $fid x
+ close $fid
+ set fid [open $f rb]
+ append d [read $fid]
+ close $fid
+ return $d
+} -cleanup {
+ removeFile $f
+} -result 341234x6
+
test iocmd-14.1 {file id parsing errors} {
list [catch {eof gorp} msg] $msg $::errorCode
@@ -600,7 +639,7 @@ test iocmd-15.9 {Tcl_FcopyObjCmd} {fcopy} {
} "1 {channel \"$rfile\" wasn't opened for writing}"
test iocmd-15.10 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $rfile $wfile foo bar} msg] $msg
-} {1 {bad switch "foo": must be -size or -command}}
+} {1 {bad option "foo": must be -size or -command}}
test iocmd-15.11 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $rfile $wfile -size foo} msg] $msg
} {1 {expected integer but got "foo"}}
@@ -617,11 +656,10 @@ close $wfile
test iocmd-20.0 {chan, wrong#args} {
catch {chan} msg
set msg
-} {wrong # args: should be "chan subcommand ?argument ...?"}
-test iocmd-20.1 {chan, unknown method} {
- catch {chan foo} msg
- set msg
-} {unknown or ambiguous subcommand "foo": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, pending, postevent, puts, read, seek, tell, or truncate}
+} {wrong # args: should be "chan subcommand ?arg ...?"}
+test iocmd-20.1 {chan, unknown method} -body {
+ chan foo
+} -returnCodes error -match glob -result {unknown or ambiguous subcommand "foo": must be *}
# --- --- --- --------- --------- ---------
# chan create, and method "initalize"
@@ -981,7 +1019,7 @@ test iocmd-23.1 {chan read, regular data return} -match glob -body {
close $c
rename foo {}
set res
-} -result {{read rc* 4096} {read rc* 4096} {watch rc* {}} snarfsnarf}
+} -result {{read rc* 4096} {read rc* 4096} snarfsnarf}
test iocmd-23.2 {chan read, bad data return, to much} -match glob -body {
set res {}
proc foo {args} {
@@ -993,7 +1031,7 @@ test iocmd-23.2 {chan read, bad data return, to much} -match glob -body {
close $c
rename foo {}
set res
-} -result {{read rc* 4096} {watch rc* {}} 1 {read delivered more than requested}}
+} -result {{read rc* 4096} 1 {read delivered more than requested}}
test iocmd-23.3 {chan read, for non-readable channel} -match glob -body {
set res {}
proc foo {args} {
@@ -1016,7 +1054,7 @@ test iocmd-23.4 {chan read, error return} -match glob -body {
close $c
rename foo {}
set res
-} -result {{read rc* 4096} {watch rc* {}} 1 BOOM!}
+} -result {{read rc* 4096} 1 BOOM!}
test iocmd-23.5 {chan read, break return is error} -match glob -body {
set res {}
proc foo {args} {
@@ -1028,7 +1066,7 @@ test iocmd-23.5 {chan read, break return is error} -match glob -body {
close $c
rename foo {}
set res
-} -result {{read rc* 4096} {watch rc* {}} 1 *bad code*}
+} -result {{read rc* 4096} 1 *bad code*}
test iocmd-23.6 {chan read, continue return is error} -match glob -body {
set res {}
proc foo {args} {
@@ -1040,7 +1078,7 @@ test iocmd-23.6 {chan read, continue return is error} -match glob -body {
close $c
rename foo {}
set res
-} -result {{read rc* 4096} {watch rc* {}} 1 *bad code*}
+} -result {{read rc* 4096} 1 *bad code*}
test iocmd-23.7 {chan read, custom return is error} -match glob -body {
set res {}
proc foo {args} {
@@ -1052,7 +1090,7 @@ test iocmd-23.7 {chan read, custom return is error} -match glob -body {
close $c
rename foo {}
set res
-} -result {{read rc* 4096} {watch rc* {}} 1 *bad code*}
+} -result {{read rc* 4096} 1 *bad code*}
test iocmd-23.8 {chan read, level is squashed} -match glob -body {
set res {}
proc foo {args} {
@@ -1064,7 +1102,7 @@ test iocmd-23.8 {chan read, level is squashed} -match glob -body {
close $c
rename foo {}
set res
-} -result {{read rc* 4096} {watch rc* {}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}}
+} -result {{read rc* 4096} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}}
test iocmd-23.9 {chan read, no data means eof} -match glob -setup {
set res {}
proc foo {args} {
@@ -1080,7 +1118,7 @@ test iocmd-23.9 {chan read, no data means eof} -match glob -setup {
close $c
rename foo {}
unset res
-} -result {{read rc* 4096} {watch rc* {}} {} 1}
+} -result {{read rc* 4096} {} 1}
test iocmd-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glob -setup {
set res {}
proc foo {args} {
@@ -1096,7 +1134,7 @@ test iocmd-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glo
close $c
rename foo {}
unset res
-} -result {{read rc* 4096} {watch rc* {}} {} 0}
+} -result {{read rc* 4096} {} 0}
test iocmd-23.11 {chan read, close pulls the rug out} -match glob -body {
set res {}
proc foo {args} {
@@ -1410,14 +1448,14 @@ test iocmd-25.10 {chan configure, cgetall, level is ignored} -match glob -body {
test iocmd-26.1 {chan configure, set standard option} -match glob -body {
set res {}
proc foo {args} {
- oninit configure; onfinal; track; return
+ oninit configure; onfinal; track; note MUST_NOT_HAPPEN; return
}
set c [chan create {r w} foo]
note [fconfigure $c -translation lf]
close $c
rename foo {}
set res
-} -result {{watch rc* {}} {}}
+} -result {{}}
test iocmd-26.2 {chan configure, set option, error return} -match glob -body {
set res {}
proc foo {args} {
@@ -1955,7 +1993,7 @@ test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body {
close $c
rename foo {}
set res
-} -result {{watch rc* read} {} TOCK {watch rc* read} {} {watch rc* {}}}
+} -result {{watch rc* read} {} TOCK {} {watch rc* {}}}
test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return}
@@ -1968,7 +2006,7 @@ test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body {
close $c
rename foo {}
set res
-} -result {{watch rc* write} {} TOCK {watch rc* write} {} {watch rc* {}}}
+} -result {{watch rc* write} {} TOCK {} {watch rc* {}}}
test iocmd-31.8 {chan postevent after close throws error} -match glob -setup {
proc foo {args} {oninit; onfinal; track; return}
proc dummy args { return }
@@ -2054,7 +2092,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
@@ -2071,9 +2108,9 @@ test iocmd-32.2 {delete interp of reflected chan} {
# on the double free
interp create slave
slave eval {
- proc no-op args {}
- proc driver {sub args} {return {initialize finalize watch read}}
- chan event [chan create read driver] readable no-op
+ proc no-op args {}
+ proc driver {sub args} {return {initialize finalize watch read}}
+ chan event [chan create read driver] readable no-op
}
interp delete slave
} {}
@@ -2090,23 +2127,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
@@ -2115,7 +2135,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
@@ -2124,22 +2145,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.
@@ -2147,15 +2169,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
}
@@ -2176,7 +2198,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}
@@ -2189,7 +2211,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}
@@ -2200,7 +2222,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}
@@ -2211,7 +2233,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}
@@ -2223,7 +2245,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}
@@ -2235,7 +2257,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}
@@ -2247,7 +2269,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}
@@ -2259,7 +2281,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
@@ -2278,7 +2300,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} {
@@ -2293,7 +2315,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} {
@@ -2307,7 +2329,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} {
@@ -2323,7 +2345,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} {
@@ -2339,7 +2361,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} {
@@ -2355,7 +2377,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} {
@@ -2371,7 +2393,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} {
@@ -2387,7 +2409,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} {
@@ -2407,7 +2429,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} {
@@ -2427,7 +2449,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
@@ -2447,7 +2469,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} {
@@ -2464,7 +2486,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}
@@ -2475,7 +2497,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}
@@ -2488,7 +2510,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}
@@ -2501,7 +2523,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}
@@ -2514,7 +2536,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!}
@@ -2528,7 +2550,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!}
@@ -2542,7 +2564,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!}
@@ -2556,7 +2578,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!}
@@ -2570,7 +2592,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!}
@@ -2584,7 +2606,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}
@@ -2598,7 +2620,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!}
@@ -2613,7 +2635,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} {
@@ -2632,7 +2654,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} {
@@ -2652,10 +2674,163 @@ 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]
+ catch {after cancel $::timer}
+ if {[llength $l]} {
+ set ::timer [after $::drive [list POST $ch]]
+ }
+ }
+ 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
+ # Thread exits cause leaks; Use clean thread shutdown
+ set forever yourGirl
+ }
+
+ LOG MAIN_WAITING
+ vwait forever
+ LOG MAIN_DONE
+
+ set res
+} -cleanup {
+ after cancel $::timer
+ rename LOG {}
+ rename POST {}
+ rename HANDLER {}
+ unset beat drive data forever res tid ch timer
+} -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
@@ -2671,7 +2846,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 {}
@@ -2684,7 +2859,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 {}
@@ -2700,7 +2875,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 {}
@@ -2717,7 +2892,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} {
@@ -2733,7 +2908,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} {
@@ -2749,7 +2924,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} {
@@ -2766,7 +2941,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} {
@@ -2783,7 +2958,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} {
@@ -2800,7 +2975,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} {
@@ -2818,7 +2993,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
@@ -2836,7 +3011,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} {
@@ -2852,7 +3027,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}
@@ -2864,7 +3039,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} {
@@ -2881,7 +3056,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} {
@@ -2898,7 +3073,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} {
@@ -2915,7 +3090,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} {
@@ -2933,7 +3108,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
@@ -2949,7 +3124,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} {
@@ -2965,7 +3140,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} {
@@ -2982,7 +3157,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} {
@@ -2999,7 +3174,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} {
@@ -3016,7 +3191,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} {
@@ -3034,7 +3209,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
@@ -3051,7 +3226,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!}
@@ -3065,7 +3240,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!}
@@ -3079,7 +3254,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!}
@@ -3093,7 +3268,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!}
@@ -3107,7 +3282,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}
@@ -3122,7 +3297,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}
@@ -3135,7 +3310,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}
@@ -3149,7 +3324,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}
@@ -3163,7 +3338,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}
@@ -3177,7 +3352,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!}
@@ -3191,7 +3366,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!}
@@ -3205,7 +3380,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!}
@@ -3219,7 +3394,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!}
@@ -3233,7 +3408,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}
@@ -3248,7 +3423,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}
@@ -3262,7 +3437,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}
@@ -3276,7 +3451,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}
@@ -3289,7 +3464,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
@@ -3307,7 +3482,7 @@ foreach {testname code} {
rename foo {}
set res
} -result [list [list seek rc* 0 $code] {}] \
- -constraints {testchannel testthread}
+ -constraints {testchannel thread}
}
# --- === *** ###########################
@@ -3325,7 +3500,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}
@@ -3339,7 +3514,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}
@@ -3352,7 +3527,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}
@@ -3366,7 +3541,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}
@@ -3380,7 +3555,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!}
@@ -3395,7 +3570,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!}
@@ -3409,7 +3584,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!}
@@ -3423,7 +3598,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!}
@@ -3437,7 +3612,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}
@@ -3452,7 +3627,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}
@@ -3466,7 +3641,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
@@ -3482,7 +3657,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}
@@ -3495,7 +3670,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}
@@ -3510,7 +3685,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 {}
@@ -3525,7 +3700,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* {}} {} {} {}}
# --- === *** ###########################
@@ -3545,7 +3720,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*"}}
# --- === *** ###########################
@@ -3556,12 +3731,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
@@ -3569,67 +3747,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-11-05 10:24:19 (GMT)