summaryrefslogtreecommitdiffstats
path: root/tests/ioTrans.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/ioTrans.test')
-rw-r--r--tests/ioTrans.test1879
1 files changed, 1879 insertions, 0 deletions
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
new file mode 100644
index 0000000..5a8874c
--- /dev/null
+++ b/tests/ioTrans.test
@@ -0,0 +1,1879 @@
+# -*- tcl -*-
+# Functionality covered: operation of the reflected transformation
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 2007 Andreas Kupries <andreask@activestate.com>
+# <akupries@shaw.ca>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+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 testchannel [llength [info commands testchannel]]
+testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
+
+# testchannel cut|splice Both needed to test the reflection in threads.
+# thread::send
+
+#----------------------------------------------------------------------
+
+# ### ### ### ######### ######### #########
+## Testing the reflected transformation.
+
+# Helper commands to record the arguments to handler methods. Stored in a
+# script so that the tests needing this code do not need their own copy but
+# can access this variable.
+
+set helperscript {
+ if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest 2
+ namespace import -force ::tcltest::*
+ }
+
+ # This forces the return options to be in the order that the test expects!
+ variable optorder {
+ -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?!
+ -errorstack !?!
+ }
+ proc noteOpts opts {
+ variable optorder
+ lappend ::res [dict merge $optorder $opts]
+ }
+
+ # Helper command, canned result for 'initialize' method. Gets the
+ # optional methods as arguments. Use return features to post the result
+ # higher up.
+
+ proc handle.initialize {args} {
+ upvar args hargs
+ if {[lindex $hargs 0] eq "initialize"} {
+ return -code return [list {*}$args initialize finalize read write]
+ }
+ }
+ proc handle.finalize {} {
+ upvar args hargs
+ if {[lindex $hargs 0] eq "finalize"} {
+ return -code return ""
+ }
+ }
+ proc handle.read {} {
+ upvar args hargs
+ if {[lindex $hargs 0] eq "read"} {
+ return -code return "@"
+ }
+ }
+ proc handle.drain {} {
+ upvar args hargs
+ if {[lindex $hargs 0] eq "drain"} {
+ return -code return "<>"
+ }
+ }
+ proc handle.clear {} {
+ upvar args hargs
+ if {[lindex $hargs 0] eq "clear"} {
+ return -code return ""
+ }
+ }
+
+ proc tempchan {{mode r+}} {
+ global tempchan
+ return [set tempchan [open [makeFile {test data} tempchanfile] $mode]]
+ }
+ proc tempdone {} {
+ global tempchan
+ catch {close $tempchan}
+ removeFile tempchanfile
+ return
+ }
+ proc tempview {} { viewFile tempchanfile }
+}
+
+# Set everything up in the main thread.
+eval $helperscript
+
+#puts <<[file channels]>>
+
+# ### ### ### ######### ######### #########
+
+test iortrans-1.0 {chan, wrong#args} -returnCodes error -body {
+ chan
+} -result {wrong # args: should be "chan subcommand ?arg ...?"}
+test iortrans-1.1 {chan, unknown method} -returnCodes error -body {
+ chan foo
+} -match glob -result {unknown or ambiguous subcommand "foo": must be*}
+
+# --- --- --- --------- --------- ---------
+# chan push, and method "initalize"
+
+test iortrans-2.0 {chan push, wrong#args, not enough} -returnCodes error -body {
+ chan push
+} -result {wrong # args: should be "chan push channel cmdprefix"}
+test iortrans-2.1 {chan push, wrong#args, too many} -returnCodes error -body {
+ chan push a b c
+} -result {wrong # args: should be "chan push channel cmdprefix"}
+test iortrans-2.2 {chan push, invalid channel} -setup {
+ proc foo {} {}
+} -returnCodes error -body {
+ chan push {} foo
+} -cleanup {
+ rename foo {}
+} -result {can not find channel named ""}
+test iortrans-2.3 {chan push, bad handler, not a list} -body {
+ chan push [tempchan] "foo \{"
+} -returnCodes error -cleanup {
+ tempdone
+} -result {unmatched open brace in list}
+test iortrans-2.4 {chan push, bad handler, not a command} -body {
+ chan push [tempchan] foo
+} -returnCodes error -cleanup {
+ tempdone
+} -result {invalid command name "foo"}
+test iortrans-2.5 {chan push, initialize failed, bad signature} -body {
+ proc foo {} {}
+ chan push [tempchan] foo
+} -returnCodes error -cleanup {
+ tempdone
+ rename foo {}
+} -result {wrong # args: should be "foo"}
+test iortrans-2.6 {chan push, initialize failed, bad signature} -body {
+ proc foo {} {}
+ chan push [tempchan] ::foo
+} -returnCodes error -cleanup {
+ tempdone
+ rename foo {}
+} -result {wrong # args: should be "::foo"}
+test iortrans-2.7 {chan push, initialize failed, bad result, not a list} -body {
+ proc foo {args} {return "\{"}
+ catch {chan push [tempchan] foo}
+ return $::errorInfo
+} -cleanup {
+ tempdone
+ rename foo {}
+} -match glob -result {chan handler "foo initialize" returned non-list: *}
+test iortrans-2.8 {chan push, initialize failed, bad result, not a list} -body {
+ proc foo {args} {return \{\{\}}
+ chan push [tempchan] foo
+} -returnCodes error -cleanup {
+ tempdone
+ rename foo {}
+} -match glob -result {chan handler "foo initialize" returned non-list: *}
+test iortrans-2.9 {chan push, initialize failed, bad result, empty list} -body {
+ proc foo {args} {}
+ chan push [tempchan] foo
+} -returnCodes error -cleanup {
+ tempdone
+ rename foo {}
+} -match glob -result {*all required methods*}
+test iortrans-2.10 {chan push, initialize failed, bad result, bogus method name} -body {
+ proc foo {args} {return 1}
+ chan push [tempchan] foo
+} -returnCodes error -cleanup {
+ tempdone
+ rename foo {}
+} -match glob -result {*bad method "1": must be *}
+test iortrans-2.11 {chan push, initialize failed, bad result, bogus method name} -body {
+ proc foo {args} {return {a b c}}
+ chan push [tempchan] foo
+} -returnCodes error -cleanup {
+ tempdone
+ rename foo {}
+} -match glob -result {*bad method "c": must be *}
+test iortrans-2.12 {chan push, initialize failed, bad result, required methods missing} -body {
+ # Required: initialize, and finalize.
+ proc foo {args} {return {initialize}}
+ chan push [tempchan] foo
+} -returnCodes error -cleanup {
+ tempdone
+ rename foo {}
+} -match glob -result {*all required methods*}
+test iortrans-2.13 {chan push, initialize failed, bad result, illegal method name} -body {
+ proc foo {args} {return {initialize finalize BOGUS}}
+ chan push [tempchan] foo
+} -returnCodes error -cleanup {
+ tempdone
+ rename foo {}
+} -match glob -result {*returned bad method "BOGUS": must be clear, drain, finalize, flush, initialize, limit?, read, or write}
+test iortrans-2.14 {chan push, initialize failed, bad result, mode/handler mismatch} -body {
+ proc foo {args} {return {initialize finalize}}
+ chan push [tempchan] foo
+} -returnCodes error -cleanup {
+ tempdone
+ rename foo {}
+} -match glob -result {*makes the channel inaccessible}
+# iortrans-2.15 event/watch methods elimimated, removed these tests.
+# iortrans-2.16
+test iortrans-2.17 {chan push, initialize failed, bad result, drain/read mismatch} -body {
+ proc foo {args} {return {initialize finalize drain write}}
+ chan push [tempchan] foo
+} -returnCodes error -cleanup {
+ tempdone
+ rename foo {}
+} -match glob -result {*supports "drain" but not "read"}
+test iortrans-2.18 {chan push, initialize failed, bad result, flush/write mismatch} -body {
+ proc foo {args} {return {initialize finalize flush read}}
+ chan push [tempchan] foo
+} -returnCodes error -cleanup {
+ tempdone
+ rename foo {}
+} -match glob -result {*supports "flush" but not "write"}
+test iortrans-2.19 {chan push, initialize ok, creates channel} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ global res
+ lappend res $args
+ if {[lindex $args 0] ne "initialize"} {return}
+ return {initialize finalize drain flush read write}
+ }
+ lappend res [file channel rt*]
+ lappend res [chan push [tempchan] foo]
+ lappend res [close [lindex $res end]]
+ lappend res [file channel rt*]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{} {initialize rt* {read write}} file* {drain rt*} {flush rt*} {finalize rt*} {} {}}
+test iortrans-2.20 {chan push, init failure -> no channel, no finalize} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ global res
+ lappend res $args
+ return
+ }
+ lappend res [file channel rt*]
+ lappend res [catch {chan push [tempchan] foo} msg] $msg
+ lappend res [file channel rt*]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{} {initialize rt* {read write}} 1 {*all required methods*} {}}
+
+# --- --- --- --------- --------- ---------
+# method finalize (via close)
+
+# General note: file channels rt* finds the transform channel, however the
+# name reported will be that of the underlying base driver, fileXX here. This
+# actually allows us to see if the whole channel is gone, or only the
+# transformation, but not the base.
+
+test iortrans-3.1 {chan finalize, handler destruction has no effect on channel} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ lappend ::res $args
+ handle.initialize
+ return
+ }
+ lappend res [set c [chan push [tempchan] foo]]
+ rename foo {}
+ lappend res [file channels file*]
+ lappend res [file channels rt*]
+ lappend res [catch {close $c} msg] $msg
+ lappend res [file channels file*]
+ lappend res [file channels rt*]
+} -cleanup {
+ tempdone
+} -result {{initialize rt* {read write}} file* file* {} 1 {invalid command name "foo"} {} {}}
+test iortrans-3.2 {chan finalize, for close} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ lappend ::res $args
+ handle.initialize
+ return
+ }
+ lappend res [set c [chan push [tempchan] foo]]
+ close $c
+ # Close deleted the channel.
+ lappend res [file channels rt*]
+ # Channel destruction does not kill handler command!
+ lappend res [info command foo]
+} -cleanup {
+ rename foo {}
+ tempdone
+} -result {{initialize rt* {read write}} file* {finalize rt*} {} foo}
+test iortrans-3.3 {chan finalize, for close, error, close error} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ lappend ::res $args
+ handle.initialize
+ return -code error 5
+ }
+ lappend res [set c [chan push [tempchan] foo]]
+ lappend res [catch {close $c} msg] $msg
+ # Channel is gone despite error.
+ lappend res [file channels rt*]
+} -cleanup {
+ rename foo {}
+ tempdone
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}}
+test iortrans-3.4 {chan finalize, for close, error, close error} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ lappend ::res $args
+ handle.initialize
+ error FOO
+ }
+ lappend res [set c [chan push [tempchan] foo]]
+ lappend res [catch {close $c} msg] $msg $::errorInfo
+} -cleanup {
+ rename foo {}
+ tempdone
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO {FOO
+*"close $c"}}
+test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ lappend ::res $args
+ handle.initialize
+ return SOMETHING
+ }
+ lappend res [set c [chan push [tempchan] foo]]
+ lappend res [catch {close $c} msg] $msg
+} -cleanup {
+ rename foo {}
+ tempdone
+} -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}}
+test iortrans-3.6 {chan finalize, for close, break, close error} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ lappend ::res $args
+ handle.initialize
+ return -code 3
+ }
+ lappend res [set c [chan push [tempchan] foo]]
+ lappend res [catch {close $c} msg] $msg
+} -cleanup {
+ rename foo {}
+ tempdone
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
+test iortrans-3.7 {chan finalize, for close, continue, close error} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ lappend ::res $args
+ handle.initialize
+ return -code 4
+ }
+ lappend res [set c [chan push [tempchan] foo]]
+ lappend res [catch {close $c} msg] $msg
+} -cleanup {
+ rename foo {}
+ tempdone
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
+test iortrans-3.8 {chan finalize, for close, custom code, close error} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ lappend ::res $args
+ handle.initialize
+ return -code 777 BANG
+ }
+ lappend res [set c [chan push [tempchan] foo]]
+ lappend res [catch {close $c} msg] $msg
+} -cleanup {
+ rename foo {}
+ tempdone
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
+test iortrans-3.9 {chan finalize, for close, ignore level, close error} -setup {
+ set res {}
+} -body {
+ proc foo {args} {
+ lappend ::res $args
+ handle.initialize
+ return -level 5 -code 777 BANG
+ }
+ lappend res [set c [chan push [tempchan] foo]]
+ lappend res [catch {close $c} msg opt] $msg
+ noteOpts $opt
+} -match glob -cleanup {
+ rename foo {}
+ tempdone
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}}
+
+# --- === *** ###########################
+# method read (via read)
+
+test iortrans-4.1 {chan read, transform call and return} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return snarf
+ }
+ set c [chan push [tempchan] foo]
+ lappend res [read $c 10]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{read rt* {test data
+}} snarf}
+test iortrans-4.2 {chan read, for non-readable channel} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args MUST_NOT_HAPPEN
+ }
+ set c [chan push [tempchan w] foo]
+ lappend res [catch {read $c 2} msg] $msg
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {1 {channel "file*" wasn't opened for reading}}
+test iortrans-4.3 {chan read, error return} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -code error BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res [catch {read $c 2} msg] $msg
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{read rt* {test data
+}} 1 BOOM!}
+test iortrans-4.4 {chan read, break return is error} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -code break BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res [catch {read $c 2} msg] $msg
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{read rt* {test data
+}} 1 *bad code*}
+test iortrans-4.5 {chan read, continue return is error} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -code continue BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res [catch {read $c 2} msg] $msg
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{read rt* {test data
+}} 1 *bad code*}
+test iortrans-4.6 {chan read, custom return is error} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -code 777 BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res [catch {read $c 2} msg] $msg
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{read rt* {test data
+}} 1 *bad code*}
+test iortrans-4.7 {chan read, level is squashed} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -level 55 -code 777 BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res [catch {read $c 2} msg opt] $msg
+ noteOpts $opt
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{read rt* {test data
+}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}}
+test iortrans-4.8 {chan read, read, bug 2921116} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {fd args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ # Kill and recreate transform while it is operating
+ chan pop $fd
+ chan push $fd [list foo $fd]
+ }
+ set c [chan push [set c [tempchan]] [list foo $c]]
+ lappend res [read $c]
+ #lappend res [gets $c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{read rt* {test data
+}} file*}
+test iortrans-4.9 {chan read, gets, bug 2921116} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {fd args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ # Kill and recreate transform while it is operating
+ chan pop $fd
+ chan push $fd [list foo $fd]
+ }
+ set c [chan push [set c [tempchan]] [list foo $c]]
+ lappend res [gets $c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{read rt* {test data
+}} file*}
+
+# --- === *** ###########################
+# method write (via puts)
+
+test iortrans-5.1 {chan write, regular write} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return transformresult
+ }
+ set c [chan push [tempchan] foo]
+ puts -nonewline $c snarf
+ flush $c
+ close $c
+ lappend res [tempview]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{write rt* snarf} transformresult}
+test iortrans-5.2 {chan write, no write is ok, no change to file} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return
+ }
+ set c [chan push [tempchan] foo]
+ puts -nonewline $c snarfsnarfsnarf
+ flush $c
+ close $c
+ lappend res [tempview]; # This has to show the original data, as nothing was written
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{write rt* snarfsnarfsnarf} {test data}}
+test iortrans-5.3 {chan write, failed write} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -code error FAIL!
+ }
+ set c [chan push [tempchan] foo]
+ puts -nonewline $c snarfsnarfsnarf
+ lappend res [catch {flush $c} msg] $msg
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{write rt* snarfsnarfsnarf} 1 FAIL!}
+test iortrans-5.4 {chan write, non-writable channel} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args MUST_NOT_HAPPEN
+ return
+ }
+ set c [chan push [tempchan r] foo]
+ lappend res [catch {
+ puts -nonewline $c snarfsnarfsnarf
+ flush $c
+ } msg] $msg
+} -cleanup {
+ close $c
+ tempdone
+ rename foo {}
+} -result {1 {channel "file*" wasn't opened for writing}}
+test iortrans-5.5 {chan write, failed write, error return} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -code error BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res [catch {
+ puts -nonewline $c snarfsnarfsnarf
+ flush $c
+ } msg] $msg
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{write rt* snarfsnarfsnarf} 1 BOOM!}
+test iortrans-5.6 {chan write, failed write, error return} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ error BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res {*}[catch {
+ puts -nonewline $c snarfsnarfsnarf
+ flush $c
+ } msg] $msg
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{write rt* snarfsnarfsnarf} 1 BOOM!}
+test iortrans-5.7 {chan write, failed write, break return is error} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -code break BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res [catch {
+ puts -nonewline $c snarfsnarfsnarf
+ flush $c
+ } msg] $msg
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
+test iortrans-5.8 {chan write, failed write, continue return is error} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -code continue BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res [catch {
+ puts -nonewline $c snarfsnarfsnarf
+ flush $c
+ } msg] $msg
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
+test iortrans-5.9 {chan write, failed write, custom return is error} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -code 777 BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res [catch {
+ puts -nonewline $c snarfsnarfsnarf
+ flush $c
+ } msg] $msg
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
+test iortrans-5.10 {chan write, failed write, level is ignored} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -level 55 -code 777 BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res [catch {
+ puts -nonewline $c snarfsnarfsnarf
+ flush $c
+ } msg opt] $msg
+ noteOpts $opt
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline * -errorinfo *bad code*subcommand "write"*}}
+test iortrans-5.11 {chan write, bug 2921116} -match glob -setup {
+ set res {}
+ set level 0
+} -body {
+ proc foo {fd args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ # pop - invokes flush - invokes 'foo write' - infinite recursion - stop it
+ global level
+ if {$level} {
+ return
+ }
+ incr level
+ # Kill and recreate transform while it is operating
+ chan pop $fd
+ chan push $fd [list foo $fd]
+ }
+ set c [chan push [set c [tempchan]] [list foo $c]]
+ lappend res [puts -nonewline $c abcdef]
+ lappend res [flush $c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{} {write rt* abcdef} {write rt* abcdef} {}}
+
+# --- === *** ###########################
+# method limit?, drain (via read)
+
+test iortrans-6.1 {chan read, read limits} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize limit?
+ handle.finalize
+ lappend ::res $args
+ handle.read
+ return 6
+ }
+ set c [chan push [tempchan] foo]
+ lappend res [read $c 10]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{limit? rt*} {read rt* {test d}} {limit? rt*} {read rt* {ata
+}} {limit? rt*} @@}
+test iortrans-6.2 {chan read, read transform drain on eof} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize drain
+ handle.finalize
+ lappend ::res $args
+ handle.read
+ handle.drain
+ return
+ }
+ set c [chan push [tempchan] foo]
+ lappend res [read $c]
+ lappend res [close $c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{read rt* {test data
+}} {drain rt*} @<> {}}
+
+# --- === *** ###########################
+# method clear (via puts, seek)
+
+test iortrans-7.1 {chan write, write clears read buffers} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize clear
+ handle.finalize
+ lappend ::res $args
+ handle.clear
+ return transformresult
+ }
+ set c [chan push [tempchan] foo]
+ puts -nonewline $c snarf
+ flush $c
+ return $res
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{clear rt*} {write rt* snarf}}
+test iortrans-7.2 {seek clears read buffers} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize clear
+ handle.finalize
+ lappend ::res $args
+ return
+ }
+ set c [chan push [tempchan] foo]
+ seek $c 2
+ return $res
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{clear rt*}}
+test iortrans-7.3 {clear, any result is ignored} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize clear
+ handle.finalize
+ lappend ::res $args
+ return -code error "X"
+ }
+ set c [chan push [tempchan] foo]
+ seek $c 2
+ return $res
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{clear rt*}}
+test iortrans-7.4 {chan clear, bug 2921116} -match glob -setup {
+ set res {}
+} -body {
+ proc foo {fd args} {
+ handle.initialize clear
+ handle.finalize
+ lappend ::res $args
+ # Kill and recreate transform while it is operating
+ chan pop $fd
+ chan push $fd [list foo $fd]
+ }
+ set c [chan push [set c [tempchan]] [list foo $c]]
+ seek $c 2
+ return $res
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{clear rt*}}
+
+# --- === *** ###########################
+# method flush (via seek, close)
+
+test iortrans-8.1 {seek flushes write buffers, ignores data} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize flush
+ handle.finalize
+ lappend ::res $args
+ return X
+ }
+ set c [chan push [tempchan] foo]
+ # Flush, no writing
+ seek $c 2
+ # The close flushes again, this modifies the file!
+ lappend res |
+ lappend res [close $c] | [tempview]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{flush rt*} | {flush rt*} {} | {teXt data}}
+test iortrans-8.2 {close flushes write buffers, writes data} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {args} {
+ handle.initialize flush
+ lappend ::res $args
+ handle.finalize
+ return .flushed.
+ }
+ set c [chan push [tempchan] foo]
+ close $c
+ lappend res [tempview]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{flush rt*} {finalize rt*} .flushed.}
+test iortrans-8.3 {chan flush, bug 2921116} -match glob -setup {
+ set res {}
+} -body {
+ proc foo {fd args} {
+ handle.initialize flush
+ handle.finalize
+ lappend ::res $args
+ # Kill and recreate transform while it is operating
+ chan pop $fd
+ chan push $fd [list foo $fd]
+ }
+ set c [chan push [set c [tempchan]] [list foo $c]]
+ seek $c 2
+ set res
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{flush rt*}}
+
+# --- === *** ###########################
+# method watch - removed from TIP (rev 1.12+)
+
+# --- === *** ###########################
+# method event - removed from TIP (rev 1.12+)
+
+# --- === *** ###########################
+# 'Pull the rug' tests. Create channel in a interpreter A, move to other
+# interpreter B, destroy the origin interpreter (A) before or during access
+# from B. Must not crash, must return proper errors.
+test iortrans-11.0 {origin interpreter of moved transform gone} -setup {
+ set ida [interp create]; #puts <<$ida>>
+ set idb [interp create]; #puts <<$idb>>
+ # Magic to get the test* commands in the slaves
+ load {} Tcltest $ida
+ load {} Tcltest $idb
+} -constraints {testchannel} -match glob -body {
+ # Set up channel and transform in interpreter
+ interp eval $ida $helperscript
+ interp eval $ida [list ::variable tempchan [tempchan]]
+ interp transfer {} $::tempchan $ida
+ set chan [interp eval $ida {
+ variable tempchan
+ proc foo {args} {
+ handle.initialize clear drain flush limit? read write
+ handle.finalize
+ lappend ::res $args
+ return
+ }
+ set chan [chan push $tempchan foo]
+ fconfigure $chan -buffering none
+ set chan
+ }]
+ # Move channel to 2nd interpreter, transform goes with it.
+ interp eval $ida [list testchannel cut $chan]
+ interp eval $idb [list testchannel splice $chan]
+ # Kill origin interpreter, then access channel from 2nd interpreter.
+ interp delete $ida
+ set res {}
+ lappend res \
+ [catch {interp eval $idb [list puts $chan shoo]} msg] $msg \
+ [catch {interp eval $idb [list tell $chan]} msg] $msg \
+ [catch {interp eval $idb [list seek $chan 1]} msg] $msg \
+ [catch {interp eval $idb [list gets $chan]} msg] $msg \
+ [catch {interp eval $idb [list close $chan]} msg] $msg
+ #lappend res [interp eval $ida {set res}]
+ # actions: clear|write|clear|write|clear|flush|limit?|drain|flush
+ # The 'tell' is ok, as it passed through the transform to the base channel
+ # without invoking the transform handler.
+} -cleanup {
+ tempdone
+} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
+test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup {
+ set ida [interp create]; #puts <<$ida>>
+ set idb [interp create]; #puts <<$idb>>
+ # Magic to get the test* commands in the slaves
+ load {} Tcltest $ida
+ load {} Tcltest $idb
+} -constraints {testchannel impossible} -match glob -body {
+ # Set up channel in thread
+ set chan [interp eval $ida $helperscript]
+ set chan [interp eval $ida {
+ proc foo {args} {
+ handle.initialize clear drain flush limit? read write
+ handle.finalize
+ lappend ::res $args
+ # Destroy interpreter during channel access. Actually not
+ # possible for an interp to destroy itself.
+ interp delete {}
+ return}
+ set chan [chan push [tempchan] foo]
+ fconfigure $chan -buffering none
+ set chan
+ }]
+ # Move channel to 2nd thread, transform goes with it.
+ interp eval $ida [list testchannel cut $chan]
+ interp eval $idb [list testchannel splice $chan]
+ # Run access from interpreter B, this will give us a synchronous 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
+ after 50
+ catch { puts $chan shoo } res
+ set res
+ }]
+} -cleanup {
+ tempdone
+} -result {Owner lost}
+test iortrans-11.2 {delete interp of reflected transform} -setup {
+ interp create slave
+ # Magic to get the test* commands into the slave
+ load {} Tcltest slave
+} -constraints {testchannel} -body {
+ # Get base channel into the slave
+ set c [tempchan]
+ testchannel cut $c
+ interp eval slave [list testchannel splice $c]
+ interp eval slave [list set c $c]
+ slave eval {
+ proc no-op args {}
+ proc driver {c sub args} {
+ return {initialize finalize read write}
+ }
+ set t [chan push $c [list driver $c]]
+ chan event $c readable no-op
+ }
+ interp delete slave
+} -cleanup {
+ tempdone
+} -result {}
+
+# ### ### ### ######### ######### #########
+## Same tests as above, but exercising the code forwarding and receiving
+## driver operations to the originator thread.
+
+# ### ### ### ######### ######### #########
+## Testing the reflected channel (Thread forwarding).
+#
+## The id numbers refer to the original test without thread forwarding, and
+## gaps due to tests not applicable to forwarding are left to keep this
+## association.
+
+# ### ### ### ######### ######### #########
+## Helper command. Runs a script in a separate thread and returns the result.
+## A channel is transfered into the thread as well, and a list of configuation
+## variables
+
+proc inthread {chan script args} {
+ # Test thread.
+ set tid [thread::create -preserved]
+ thread::send $tid {load {} Tcltest}
+
+ # Init thread configuration.
+ # - Listed variables
+ # - Id of main thread
+ # - A number of helper commands
+
+ foreach v $args {
+ upvar 1 $v x
+ thread::send $tid [list set $v $x]
+ }
+ thread::send $tid [list set mid [thread::id]]
+ thread::send $tid {
+ proc notes {} {
+ return $::notes
+ }
+ proc noteOpts opts {
+ lappend ::notes [dict merge {
+ -code !?! -level !?! -errorcode !?! -errorline !?!
+ -errorinfo !?! -errorstack !?!
+ } $opts]
+ }
+ }
+ thread::send $tid [list proc s {} [list uplevel 1 $script]]; # (*)
+
+ # Transfer channel (cut/splice aka detach/attach)
+
+ testchannel cut $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. It is also necessary for the execution of
+ # forwarded channel operations.
+
+ set ::tres ""
+ thread::send -async $tid {
+ after 50
+ catch {s} res; # This runs the script, 's' was defined at (*)
+ thread::send -async $mid [list set ::tres $res]
+ }
+ vwait ::tres
+ # Remove test thread, and return the captured result.
+
+ thread::release $tid
+ return $::tres
+}
+
+# ### ### ### ######### ######### #########
+
+test iortrans.tf-3.2 {chan finalize, for close} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ lappend ::res $args
+ handle.initialize
+ return {}
+ }
+ lappend res [set c [chan push [tempchan] foo]]
+ lappend res [inthread $c {
+ close $c
+ # Close the deleted the channel.
+ file channels rt*
+ } c]
+ # Channel destruction does not kill handler command!
+ lappend res [info command foo]
+} -cleanup {
+ rename foo {}
+} -result {{initialize rt* {read write}} file* {finalize rt*} {} foo}
+test iortrans.tf-3.3 {chan finalize, for close, error, close error} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ lappend ::res $args
+ handle.initialize
+ return -code error 5
+ }
+ lappend res [set c [chan push [tempchan] foo]]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {close $c} msg] $msg
+ # Channel is gone despite error.
+ lappend notes [file channels rt*]
+ notes
+ } c]
+} -cleanup {
+ rename foo {}
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}}
+test iortrans.tf-3.4 {chan finalize, for close, error, close errror} -setup {
+ set res {}
+} -constraints {testchannel thread} -body {
+ proc foo {args} {
+ lappend ::res $args
+ handle.initialize
+ error FOO
+ }
+ lappend res [set c [chan push [tempchan] foo]]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {close $c} msg] $msg
+ notes
+ } c]
+} -match glob -cleanup {
+ rename foo {}
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO}
+test iortrans.tf-3.5 {chan finalize, for close, arbitrary result} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ lappend ::res $args
+ handle.initialize
+ return SOMETHING
+ }
+ lappend res [set c [chan push [tempchan] foo]]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {close $c} msg] $msg
+ notes
+ } c]
+} -cleanup {
+ rename foo {}
+} -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}}
+test iortrans.tf-3.6 {chan finalize, for close, break, close error} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ lappend ::res $args
+ handle.initialize
+ return -code 3
+ }
+ lappend res [set c [chan push [tempchan] foo]]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {close $c} msg] $msg
+ notes
+ } c]
+} -cleanup {
+ rename foo {}
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
+test iortrans.tf-3.7 {chan finalize, for close, continue, close error} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ lappend ::res $args
+ handle.initialize
+ return -code 4
+ }
+ lappend res [set c [chan push [tempchan] foo]]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {close $c} msg] $msg
+ notes
+ } c]
+} -cleanup {
+ rename foo {}
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
+test iortrans.tf-3.8 {chan finalize, for close, custom code, close error} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ lappend ::res $args
+ handle.initialize
+ return -code 777 BANG
+ }
+ lappend res [set c [chan push [tempchan] foo]]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {close $c} msg] $msg
+ notes
+ } c]
+} -cleanup {
+ rename foo {}
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
+test iortrans.tf-3.9 {chan finalize, for close, ignore level, close error} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ lappend ::res $args
+ handle.initialize
+ return -level 5 -code 777 BANG
+ }
+ lappend res [set c [chan push [tempchan] foo]]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {close $c} msg opt] $msg
+ noteOpts $opt
+ notes
+ } c]
+} -cleanup {
+ rename foo {}
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}}
+
+# --- === *** ###########################
+# method read
+
+test iortrans.tf-4.1 {chan read, transform call and return} -setup {
+ set res {}
+} -constraints {testchannel thread} -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return snarf
+ }
+ set c [chan push [tempchan] foo]
+ lappend res {*}[inthread $c {
+ lappend notes [read $c 10]
+ close $c
+ notes
+ } c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -match glob -result {{read rt* {test data
+}} snarf}
+test iortrans.tf-4.2 {chan read, for non-readable channel} -setup {
+ set res {}
+} -constraints {testchannel thread} -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args MUST_NOT_HAPPEN
+ }
+ set c [chan push [tempchan w] foo]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {[read $c 2]} msg] $msg
+ close $c
+ notes
+ } c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -match glob -result {1 {channel "file*" wasn't opened for reading}}
+test iortrans.tf-4.3 {chan read, error return} -setup {
+ set res {}
+} -constraints {testchannel thread} -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -code error BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {read $c 2} msg] $msg
+ close $c
+ notes
+ } c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -match glob -result {{read rt* {test data
+}} 1 BOOM!}
+test iortrans.tf-4.4 {chan read, break return is error} -setup {
+ set res {}
+} -constraints {testchannel thread} -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -code break BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {read $c 2} msg] $msg
+ close $c
+ notes
+ } c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -match glob -result {{read rt* {test data
+}} 1 *bad code*}
+test iortrans.tf-4.5 {chan read, continue return is error} -setup {
+ set res {}
+} -constraints {testchannel thread} -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -code continue BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {read $c 2} msg] $msg
+ close $c
+ notes
+ } c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -match glob -result {{read rt* {test data
+}} 1 *bad code*}
+test iortrans.tf-4.6 {chan read, custom return is error} -setup {
+ set res {}
+} -constraints {testchannel thread} -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -code 777 BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {read $c 2} msg] $msg
+ close $c
+ notes
+ } c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -match glob -result {{read rt* {test data
+}} 1 *bad code*}
+test iortrans.tf-4.7 {chan read, level is squashed} -setup {
+ set res {}
+} -constraints {testchannel thread} -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -level 55 -code 777 BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {read $c 2} msg opt] $msg
+ noteOpts $opt
+ close $c
+ notes
+ } c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -match glob -result {{read rt* {test data
+}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}}
+
+# --- === *** ###########################
+# method write
+
+test iortrans.tf-5.1 {chan write, regular write} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return transformresult
+ }
+ set c [chan push [tempchan] foo]
+ inthread $c {
+ puts -nonewline $c snarf
+ flush $c
+ close $c
+ } c
+ lappend res [tempview]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{write rt* snarf} transformresult}
+test iortrans.tf-5.2 {chan write, no write is ok, no change to file} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return
+ }
+ set c [chan push [tempchan] foo]
+ inthread $c {
+ puts -nonewline $c snarfsnarfsnarf
+ flush $c
+ close $c
+ } c
+ lappend res [tempview]; # This has to show the original data, as nothing was written
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{write rt* snarfsnarfsnarf} {test data}}
+test iortrans.tf-5.3 {chan write, failed write} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -code error FAIL!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res {*}[inthread $c {
+ puts -nonewline $c snarfsnarfsnarf
+ lappend notes [catch {flush $c} msg] $msg
+ close $c
+ notes
+ } c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{write rt* snarfsnarfsnarf} 1 FAIL!}
+test iortrans.tf-5.4 {chan write, non-writable channel} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args MUST_NOT_HAPPEN
+ return
+ }
+ set c [chan push [tempchan r] foo]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {
+ puts -nonewline $c snarfsnarfsnarf
+ flush $c
+ } msg] $msg
+ close $c
+ notes
+ } c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {1 {channel "file*" wasn't opened for writing}}
+test iortrans.tf-5.5 {chan write, failed write, error return} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -code error BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {
+ puts -nonewline $c snarfsnarfsnarf
+ flush $c
+ } msg] $msg
+ close $c
+ notes
+ } c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{write rt* snarfsnarfsnarf} 1 BOOM!}
+test iortrans.tf-5.6 {chan write, failed write, error return} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ error BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {
+ puts -nonewline $c snarfsnarfsnarf
+ flush $c
+ } msg] $msg
+ close $c
+ notes
+ } c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{write rt* snarfsnarfsnarf} 1 BOOM!}
+test iortrans.tf-5.7 {chan write, failed write, break return is error} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -code break BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {
+ puts -nonewline $c snarfsnarfsnarf
+ flush $c
+ } msg] $msg
+ close $c
+ notes
+ } c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
+test iortrans.tf-5.8 {chan write, failed write, continue return is error} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -code continue BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {
+ puts -nonewline $c snarfsnarfsnarf
+ flush $c
+ } msg] $msg
+ close $c
+ notes
+ } c]
+} -cleanup {
+ rename foo {}
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
+test iortrans.tf-5.9 {chan write, failed write, custom return is error} -setup {
+ set res {}
+} -constraints {testchannel thread} -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -code 777 BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {
+ puts -nonewline $c snarfsnarfsnarf
+ flush $c
+ } msg] $msg
+ close $c
+ notes
+ } c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -match glob -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
+test iortrans.tf-5.10 {chan write, failed write, level is ignored} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ return -level 55 -code 777 BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ lappend res {*}[inthread $c {
+ lappend notes [catch {
+ puts -nonewline $c snarfsnarfsnarf
+ flush $c
+ } msg opt] $msg
+ noteOpts $opt
+ close $c
+ notes
+ } c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline * -errorinfo *bad code*subcommand "write"*}}
+
+# --- === *** ###########################
+# method limit?, drain (via read)
+
+test iortrans.tf-6.1 {chan read, read limits} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ handle.initialize limit?
+ handle.finalize
+ lappend ::res $args
+ handle.read
+ return 6
+ }
+ set c [chan push [tempchan] foo]
+ lappend res {*}[inthread $c {
+ lappend notes [read $c 10]
+ close $c
+ notes
+ } c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{limit? rt*} {read rt* {test d}} {limit? rt*} {read rt* {ata
+}} {limit? rt*} @@}
+test iortrans.tf-6.2 {chan read, read transform drain on eof} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ handle.initialize drain
+ handle.finalize
+ lappend ::res $args
+ handle.read
+ handle.drain
+ return
+ }
+ set c [chan push [tempchan] foo]
+ lappend res {*}[inthread $c {
+ lappend notes [read $c]
+ lappend notes [close $c]
+ } c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{read rt* {test data
+}} {drain rt*} @<> {}}
+
+# --- === *** ###########################
+# method clear (via puts, seek)
+
+test iortrans.tf-7.1 {chan write, write clears read buffers} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ handle.initialize clear
+ handle.finalize
+ lappend ::res $args
+ handle.clear
+ return transformresult
+ }
+ set c [chan push [tempchan] foo]
+ inthread $c {
+ puts -nonewline $c snarf
+ flush $c
+ close $c
+ } c
+ return $res
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{clear rt*} {write rt* snarf}}
+test iortrans.tf-7.2 {seek clears read buffers} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ handle.initialize clear
+ handle.finalize
+ lappend ::res $args
+ return
+ }
+ set c [chan push [tempchan] foo]
+ inthread $c {
+ seek $c 2
+ close $c
+ } c
+ return $res
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{clear rt*}}
+test iortrans.tf-7.3 {clear, any result is ignored} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ handle.initialize clear
+ handle.finalize
+ lappend ::res $args
+ return -code error "X"
+ }
+ set c [chan push [tempchan] foo]
+ inthread $c {
+ seek $c 2
+ close $c
+ } c
+ return $res
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{clear rt*}}
+
+# --- === *** ###########################
+# method flush (via seek, close)
+
+test iortrans.tf-8.1 {seek flushes write buffers, ignores data} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ handle.initialize flush
+ handle.finalize
+ lappend ::res $args
+ return X
+ }
+ set c [chan push [tempchan] foo]
+ lappend res {*}[inthread $c {
+ # Flush, no writing
+ seek $c 2
+ # The close flushes again, this modifies the file!
+ lappend notes | [close $c] |
+ # NOTE: The flush generated by the close is recorded immediately, the
+ # other note's here are defered until after the thread is done. This
+ # changes the order of the result a bit from the non-threaded case
+ # (The first | moves one to the right). This is an artifact of the
+ # 'inthread' framework, not of the transformation itself.
+ notes
+ } c]
+ lappend res [tempview]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{flush rt*} {flush rt*} | {} | {teXt data}}
+test iortrans.tf-8.2 {close flushes write buffers, writes data} -setup {
+ set res {}
+} -constraints {testchannel thread} -match glob -body {
+ proc foo {args} {
+ handle.initialize flush
+ lappend ::res $args
+ handle.finalize
+ return .flushed.
+ }
+ set c [chan push [tempchan] foo]
+ inthread $c {
+ close $c
+ } c
+ lappend res [tempview]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{flush rt*} {finalize rt*} .flushed.}
+
+# --- === *** ###########################
+# method watch - removed from TIP (rev 1.12+)
+
+# --- === *** ###########################
+# method event - removed from TIP (rev 1.12+)
+
+# --- === *** ###########################
+# 'Pull the rug' tests. Create channel in a thread A, move to other thread B,
+# destroy the origin thread (A) before or during access from B. Must not
+# crash, must return proper errors.
+
+test iortrans.tf-11.0 {origin thread of moved transform gone} -setup {
+ #puts <<$tcltest::mainThread>>main
+ set tida [thread::create -preserved]; #puts <<$tida>>
+ thread::send $tida {load {} Tcltest}
+ set tidb [thread::create -preserved]; #puts <<$tida>>
+ thread::send $tidb {load {} Tcltest}
+} -constraints {testchannel thread} -match glob -body {
+ # Set up channel in thread
+ thread::send $tida $helperscript
+ thread::send $tidb $helperscript
+ set chan [thread::send $tida {
+ proc foo {args} {
+ handle.initialize clear drain flush limit? read write
+ handle.finalize
+ lappend ::res $args
+ return
+ }
+ set chan [chan push [tempchan] foo]
+ fconfigure $chan -buffering none
+ set chan
+ }]
+
+ # Move channel to 2nd thread, transform goes with it.
+ thread::send $tida [list testchannel cut $chan]
+ thread::send $tidb [list testchannel splice $chan]
+
+ # Kill origin thread, then access channel from 2nd thread.
+ thread::release -wait $tida
+
+ set res {}
+ lappend res [catch {thread::send $tidb [list puts $chan shoo]} msg] $msg
+ 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
+ # The 'tell' is ok, as it passed through the transform to the base
+ # channel without invoking the transform handler.
+} -cleanup {
+ thread::send $tidb tempdone
+ thread::release $tidb
+} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
+
+testConstraint notValgrind [expr {![testConstraint valgrind]}]
+
+test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} -setup {
+ #puts <<$tcltest::mainThread>>main
+ set tida [thread::create -preserved]; #puts <<$tida>>
+ thread::send $tida {load {} Tcltest}
+ set tidb [thread::create -preserved]; #puts <<$tidb>>
+ thread::send $tidb {load {} Tcltest}
+} -constraints {testchannel thread notValgrind} -match glob -body {
+ # Set up channel in thread
+ thread::send $tida $helperscript
+ thread::send $tidb $helperscript
+ set chan [thread::send $tida {
+ proc foo {args} {
+ handle.initialize clear drain flush limit? read write
+ handle.finalize
+ lappend ::res $args
+ # destroy thread during channel access
+ thread::exit
+ }
+ set chan [chan push [tempchan] foo]
+ fconfigure $chan -buffering none
+ set chan
+ }]
+
+ # Move channel to 2nd thread, transform goes with it.
+ 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.
+ 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 50
+ catch { puts $chan shoo } res
+ catch { close $chan }
+ thread::send -async $mid [list set ::res $res]
+ }
+ vwait ::res
+ set res
+} -cleanup {
+ thread::send $tidb tempdone
+ thread::release $tidb
+} -result {Owner lost}
+
+# ### ### ### ######### ######### #########
+
+cleanupTests
+return