summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/chan.test4
-rw-r--r--tests/ioCmd.test6
-rw-r--r--tests/ioTrans.test1463
3 files changed, 1468 insertions, 5 deletions
diff --git a/tests/chan.test b/tests/chan.test
index eb09fd7..72eccbb 100644
--- a/tests/chan.test
+++ b/tests/chan.test
@@ -7,7 +7,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: chan.test,v 1.11 2007/12/13 15:26:04 dgp Exp $
+# RCS: @(#) $Id: chan.test,v 1.12 2008/06/06 19:46:38 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -24,7 +24,7 @@ test chan-1.1 {chan command general syntax} -body {
} -returnCodes error -result "wrong # args: should be \"chan subcommand ?argument ...?\""
test chan-1.2 {chan command general syntax} -body {
chan FOOBAR
-} -returnCodes error -result "unknown or ambiguous subcommand \"FOOBAR\": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, pending, postevent, puts, read, seek, tell, or truncate"
+} -returnCodes error -result "unknown or ambiguous subcommand \"FOOBAR\": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, pending, pop, postevent, push, puts, read, seek, tell, or truncate"
test chan-2.1 {chan command: blocked subcommand} -body {
chan blocked foo bar
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 82c9645..06116d3 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -13,7 +13,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: ioCmd.test,v 1.42 2008/04/24 18:51:01 andreas_kupries Exp $
+# RCS: @(#) $Id: ioCmd.test,v 1.43 2008/06/06 19:46:38 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -641,7 +641,7 @@ test iocmd-20.0 {chan, wrong#args} {
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}
+} {unknown or ambiguous subcommand "foo": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, pending, pop, postevent, push, puts, read, seek, tell, or truncate}
# --- --- --- --------- --------- ---------
# chan create, and method "initalize"
@@ -1894,7 +1894,7 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m
proc foo {args} {
oninit; onfinal; track;
# destroy interpreter during channel access
- # Actually not possible for an interp to destory itself.
+ # Actually not possible for an interp to destroy itself.
interp delete {}
return}
set chan [chan create {r w} foo]
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
new file mode 100644
index 0000000..070aab1
--- /dev/null
+++ b/tests/ioTrans.test
@@ -0,0 +1,1463 @@
+# -*- 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.
+#
+# RCS: @(#) $Id: ioTrans.test,v 1.1 2008/06/06 19:46:42 andreas_kupries Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest 2
+ namespace import -force ::tcltest::*
+}
+
+# Custom constraints used in this file
+testConstraint testchannel [llength [info commands testchannel]]
+testConstraint testthread [llength [info commands testthread]]
+
+# testchannel cut|splice Both needed to test the reflection in threads.
+# testthread 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::*
+ }
+
+ proc note {item} {global res; lappend res $item; return}
+ proc track {} {upvar args item; note $item; return}
+ proc notes {items} {foreach i $items {note $i}}
+
+ # Use to prevent *'s in pattern to match beyond the expected end
+ # of the recording.
+ proc endnote {} {note |}
+
+ # This forces the return options to be in the order that the test
+ # expects!
+ proc noteOpts opts {global res; lappend res [dict merge {
+ -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?!
+ } $opts]; return}
+
+ # Helper command, canned result for 'initialize' method. Gets the
+ # optional methods as arguments. Use return features to post the
+ # result higher up.
+
+ proc init {args} {
+ lappend args initialize finalize read write
+ return -code return $args
+ }
+ proc oninit {args} {
+ upvar args hargs
+ if {[lindex $hargs 0] ne "initialize"} {return}
+ lappend args initialize finalize read write
+ return -code return $args
+ }
+ proc onfinal {} {
+ upvar args hargs
+ if {[lindex $hargs 0] ne "finalize"} {return}
+ return -code return ""
+ }
+ proc onread {} {
+ upvar args hargs
+ if {[lindex $hargs 0] ne "read"} {return}
+ return -code return "@"
+ }
+ proc ondrain {} {
+ upvar args hargs
+ if {[lindex $hargs 0] ne "drain"} {return}
+ return -code return "<>"
+ }
+ proc onclear {} {
+ upvar args hargs
+ if {[lindex $hargs 0] ne "clear"} {return}
+ return -code return ""
+ }
+
+ proc tempchan {{mode r+}} {
+ global tempchan
+ set tempchan [open [makeFile {test data} tempchanfile] $mode]
+ return $tempchan
+ }
+
+ 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} {
+ catch {chan} msg
+ set msg
+} {wrong # args: should be "chan subcommand ?argument ...?"}
+test iortrans-1.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, pop, postevent, push, puts, read, seek, tell, or truncate}
+
+# --- --- --- --------- --------- ---------
+# chan push, and method "initalize"
+
+test iortrans-2.0 {chan push, wrong#args, not enough} {
+ catch {chan push} msg
+ set msg
+} {wrong # args: should be "chan push channel cmdprefix"}
+test iortrans-2.1 {chan push, wrong#args, too many} {
+ catch {chan push a b c} msg
+ set msg
+} {wrong # args: should be "chan push channel cmdprefix"}
+test iortrans-2.2 {chan push, invalid channel} {
+ proc foo {} {}
+ catch {chan push {} foo} msg
+ rename foo {}
+ set msg
+} {can not find channel named ""}
+test iortrans-2.3 {chan push, bad handler, not a list} {
+ catch {chan push [tempchan] "foo \{"} msg
+ tempdone
+ set msg
+} {unmatched open brace in list}
+test iortrans-2.4 {chan push, bad handler, not a command} {
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ set msg
+} {invalid command name "foo"}
+test iortrans-2.5 {chan push, initialize failed, bad signature} {
+ proc foo {} {}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} {wrong # args: should be "foo"}
+test iortrans-2.6 {chan push, initialize failed, bad signature} {
+ proc foo {} {}
+ catch {chan push [tempchan] ::foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} {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} msg
+ tempdone
+ rename foo {}
+ set ::errorInfo
+} -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 \{\{\}}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} -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} {}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} -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}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} -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}}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} -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}}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} -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}}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} -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}}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} -match glob -result {*makes the channel inacessible}
+# 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}}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} -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}}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} -match glob -result {*supports "flush" but not "write"}
+test iortrans-2.19 {chan push, initialize ok, creates channel} -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}
+ }
+ set res {}
+ lappend res [file channel rt*]
+ lappend res [chan push [tempchan] foo]
+ lappend res [close [lindex $res end]]
+ lappend res [file channel rt*]
+ tempdone
+ rename foo {}
+ set res
+} -result {{} {initialize rt* {read write}} file* {drain rt*} {flush rt*} {finalize rt*} {} {}}
+test iortrans-2.20 {chan push, init failure -> no channel, no finalize} -match glob -body {
+ proc foo {args} {
+ global res
+ lappend res $args
+ return {}
+ }
+ set res {}
+ lappend res [file channel rt*]
+ lappend res [catch {chan push [tempchan] foo} msg]
+ lappend res $msg
+ lappend res [file channel rt*]
+ tempdone
+ rename foo {}
+ set res
+} -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} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return}
+ note [set c [chan push [tempchan] foo]]
+ rename foo {}
+ note [file channels file*]
+ note [file channels rt*]
+ note [catch {close $c} msg]; note $msg
+ note [file channels file*]
+ note [file channels rt*]
+ set res
+} -result {{initialize rt* {read write}} file* file* {} 1 {invalid command name "foo"} {} {}}
+test iortrans-3.2 {chan finalize, for close} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return {}}
+ note [set c [chan push [tempchan] foo]]
+ close $c
+ # Close deleted the channel.
+ note [file channels rt*]
+ # Channel destruction does not kill handler command!
+ note [info command foo]
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} {} foo}
+test iortrans-3.3 {chan finalize, for close, error, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return -code error 5}
+ note [set c [chan push [tempchan] foo]]
+ note [catch {close $c} msg]; note $msg
+ # Channel is gone despite error.
+ note [file channels rt*]
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}}
+test iortrans-3.4 {chan finalize, for close, error, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; error FOO}
+ note [set c [chan push [tempchan] foo]]
+ note [catch {close $c} msg]; note $msg; note $::errorInfo
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO {FOO
+*"close $c"}}
+test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return SOMETHING}
+ note [set c [chan push [tempchan] foo]]
+ note [catch {close $c} msg]; note $msg
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}}
+test iortrans-3.6 {chan finalize, for close, break, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return -code 3}
+ note [set c [chan push [tempchan] foo]]
+ note [catch {close $c} msg]; note $msg
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
+test iortrans-3.7 {chan finalize, for close, continue, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return -code 4}
+ note [set c [chan push [tempchan] foo]]
+ note [catch {close $c} msg]; note $msg
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
+test iortrans-3.8 {chan finalize, for close, custom code, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return -code 777 BANG}
+ note [set c [chan push [tempchan] foo]]
+ note [catch {close $c} msg]; note $msg
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
+test iortrans-3.9 {chan finalize, for close, ignore level, close error} -match glob -setup {
+ set res {}
+} -body {
+ proc foo {args} {track; oninit; return -level 5 -code 777 BANG}
+ note [set c [chan push [tempchan] foo]]
+ note [catch {close $c} msg opt]; note $msg; noteOpts $opt
+ return $res
+} -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 (via read)
+
+test iortrans-4.1 {chan read, transform call and return} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return snarf
+ }
+ set c [chan push [tempchan] foo]
+ note [read $c 10]
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} snarf}
+test iortrans-4.2 {chan read, for non-readable channel} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track; note MUST_NOT_HAPPEN
+ }
+ set c [chan push [tempchan w] foo]
+ note [catch {read $c 2} msg]; note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {1 {channel "file*" wasn't opened for reading}}
+test iortrans-4.3 {chan read, error return} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -code error BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ note [catch {read $c 2} msg]; note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 BOOM!}
+test iortrans-4.4 {chan read, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -code break BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ note [catch {read $c 2} msg]; note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 *bad code*}
+test iortrans-4.5 {chan read, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -code continue BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ note [catch {read $c 2} msg]; note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 *bad code*}
+test iortrans-4.6 {chan read, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -code 777 BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ note [catch {read $c 2} msg]; note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 *bad code*}
+test iortrans-4.7 {chan read, level is squashed} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -level 55 -code 777 BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}}
+
+
+# --- === *** ###########################
+# method write (via puts)
+
+test iortrans-5.1 {chan write, regular write} -match glob -body {
+ set res {}
+ proc foo {args} { oninit; onfinal; track ; return transformresult }
+ set c [chan push [tempchan] foo]
+ puts -nonewline $c snarf; flush $c
+ close $c
+ note [tempview]
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarf} transformresult}
+test iortrans-5.2 {chan write, no write is ok, no change to file} -match glob -body {
+ set res {}
+ proc foo {args} { oninit; onfinal; track ; return {} }
+ set c [chan push [tempchan] foo]
+ puts -nonewline $c snarfsnarfsnarf; flush $c
+ close $c
+ note [tempview];# This has to show the original data, as nothing was written
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} {test data}}
+test iortrans-5.3 {chan write, failed write} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code error FAIL!}
+ set c [chan push [tempchan] foo]
+ puts -nonewline $c snarfsnarfsnarf
+ note [catch {flush $c} msg] ; note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 FAIL!}
+test iortrans-5.4 {chan write, non-writable channel} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}
+ set c [chan push [tempchan r] foo]
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]; note $msg
+ close $c
+ tempdone
+ rename foo {}
+ set res
+} -result {1 {channel "file*" wasn't opened for writing}}
+test iortrans-5.5 {chan write, failed write, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code error BOOM!}
+ set c [chan push [tempchan] foo]
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 BOOM!}
+test iortrans-5.6 {chan write, failed write, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; error BOOM!}
+ set c [chan push [tempchan] foo]
+ notes [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 BOOM!}
+test iortrans-5.7 {chan write, failed write, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code break BOOM!}
+ set c [chan push [tempchan] foo]
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
+test iortrans-5.8 {chan write, failed write, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code continue BOOM!}
+ set c [chan push [tempchan] foo]
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
+test iortrans-5.9 {chan write, failed write, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!}
+ set c [chan push [tempchan] foo]
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
+test iortrans-5.10 {chan write, failed write, level is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!}
+ set c [chan push [tempchan] foo]
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt]
+ note $msg
+ noteOpts $opt
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}}
+
+# --- === *** ###########################
+# method limit?, drain (via read)
+
+test iortrans-6.1 {chan read, read limits} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit limit?; onfinal; track ; onread
+ return 6
+ }
+ set c [chan push [tempchan] foo]
+ note [read $c 10]
+ tempdone
+ rename foo {}
+ set res
+} -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} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit drain; onfinal; track ; onread ; ondrain
+ return
+ }
+ set c [chan push [tempchan] foo]
+ note [read $c]
+ note [close $c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} {drain rt*} @<> {}}
+
+# --- === *** ###########################
+# method clear (via puts, seek)
+
+test iortrans-7.1 {chan write, write clears read buffers} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit clear; onfinal; track ; onclear
+ return transformresult
+ }
+ set c [chan push [tempchan] foo]
+ puts -nonewline $c snarf; flush $c
+ tempdone
+ rename foo {}
+ set res
+} -result {{clear rt*} {write rt* snarf}}
+test iortrans-7.2 {seek clears read buffers} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit clear; onfinal; track
+ return
+ }
+ set c [chan push [tempchan] foo]
+ seek $c 2
+ tempdone
+ rename foo {}
+ set res
+} -result {{clear rt*}}
+test iortrans-7.3 {clear, any result is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit clear; onfinal; track
+ return -code error "X"
+ }
+ set c [chan push [tempchan] foo]
+ seek $c 2
+ tempdone
+ rename foo {}
+ set res
+} -result {{clear rt*}}
+
+# --- === *** ###########################
+# method flush (via seek, close)
+
+test iortrans-8.1 {seek flushes write buffers, ignores data} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit flush; onfinal; track
+ return X
+ }
+ set c [chan push [tempchan] foo]
+ # Flush, no writing
+ seek $c 2
+ # The close flushes again, this modifies the file!
+ note | ; note [close $c] ; note |
+ note [tempview]
+ tempdone
+ rename foo {}
+ set res
+} -result {{flush rt*} | {flush rt*} {} | {teXt data}}
+
+test iortrans-8.2 {close flushes write buffers, writes data} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit flush; track ; onfinal
+ return .flushed.
+ }
+ set c [chan push [tempchan] foo]
+ close $c
+ note [tempview]
+ tempdone
+ rename foo {}
+ set res
+} -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 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} -match glob -body {
+
+ 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
+
+ # Set up channel and transform in interpreter
+ interp eval $ida $helperscript
+ set chan [interp eval $ida {
+ proc foo {args} {oninit clear drain flush limit? read write; onfinal; track; 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
+ lappend res [catch {interp eval $idb [list tell $chan]} msg] $msg
+ lappend res [catch {interp eval $idb [list seek $chan 1]} msg] $msg
+ lappend res [catch {interp eval $idb [list gets $chan]} msg] $msg
+ lappend res [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
+ set res
+ # The 'tell' is ok, as it passed through the transform to the base
+ # channel without invoking the transform handler.
+} -constraints {testchannel} \
+ -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} -match glob -body {
+
+ 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
+
+ # Set up channel in thread
+ set chan [interp eval $ida $helperscript]
+ set chan [interp eval $ida {
+ proc foo {args} {
+ oninit clear drain flush limit? read write; onfinal; track;
+ # 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 2000
+ catch { puts $chan shoo } res
+ set res
+ }]
+ set res
+} -constraints {testchannel impossible} \
+ -result {Owner lost}
+
+# ### ### ### ######### ######### #########
+## Same tests as above, but exercising the code forwarding and
+## receiving driver operations to the originator thread.
+
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+## 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.
+
+# Duplicate of code in "thread.test", and "ioCmd.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 a list
+## of configuation variables
+
+proc inthread {chan script args} {
+ # Test thread.
+
+ set tid [testthread create]
+
+ # Init thread configuration.
+ # - Listed variables
+ # - Id of main thread
+ # - A number of helper commands
+
+ foreach v $args {
+ upvar 1 $v x
+ testthread send $tid [list set $v $x]
+ }
+ testthread send $tid [list set mid $tcltest::mainThread]
+ testthread 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]]; # (*)
+
+ # Transfer channel (cut/splice aka detach/attach)
+
+ testchannel cut $chan
+ testthread 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 ""
+ testthread send -async $tid {
+ after 500
+ catch {s} res; # This runs the script, 's' was defined at (*)
+ testthread send -async $mid [list set ::tres $res]
+ }
+ vwait ::tres
+ # Remove test thread, and return the captured result.
+
+ tcltest::threadReap
+ return $::tres
+}
+
+# ### ### ### ######### ######### #########
+
+# ### ### ### ######### ######### #########
+
+test iortrans.tf-3.2 {chan finalize, for close} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return {}}
+ note [set c [chan push [tempchan] foo]]
+ note [inthread $c {
+ close $c
+ # Close the deleted the channel.
+ file channels rt*
+ } c]
+ # Channel destruction does not kill handler command!
+ note [info command foo]
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {{initialize rt* {read write}} file* {finalize rt*} {} foo}
+test iortrans.tf-3.3 {chan finalize, for close, error, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return -code error 5}
+ note [set c [chan push [tempchan] foo]]
+ notes [inthread $c {
+ note [catch {close $c} msg]; note $msg
+ # Channel is gone despite error.
+ note [file channels rt*]
+ notes
+ } c]
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}}
+test iortrans.tf-3.4 {chan finalize, for close, error, close errror} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; error FOO}
+ note [set c [chan push [tempchan] foo]]
+ notes [inthread $c {
+ note [catch {close $c} msg]; note $msg
+ notes
+ } c]
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO}
+test iortrans.tf-3.5 {chan finalize, for close, arbitrary result} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return SOMETHING}
+ note [set c [chan push [tempchan] foo]]
+ notes [inthread $c {
+ note [catch {close $c} msg]; note $msg
+ notes
+ } c]
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}}
+test iortrans.tf-3.6 {chan finalize, for close, break, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return -code 3}
+ note [set c [chan push [tempchan] foo]]
+ notes [inthread $c {
+ note [catch {close $c} msg]; note $msg
+ notes
+ } c]
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \
+ -constraints {testchannel testthread}
+
+
+test iortrans.tf-3.7 {chan finalize, for close, continue, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return -code 4}
+ note [set c [chan push [tempchan] foo]]
+ notes [inthread $c {
+ note [catch {close $c} msg]; note $msg
+ notes
+ } c]
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \
+ -constraints {testchannel testthread}
+test iortrans.tf-3.8 {chan finalize, for close, custom code, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return -code 777 BANG}
+ note [set c [chan push [tempchan] foo]]
+ notes [inthread $c {
+ note [catch {close $c} msg]; note $msg
+ notes
+ } c]
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \
+ -constraints {testchannel testthread}
+test iortrans.tf-3.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}
+ note [set c [chan push [tempchan] foo]]
+ notes [inthread $c {
+ note [catch {close $c} msg opt]; note $msg; noteOpts $opt
+ notes
+ } c]
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} \
+ -constraints {testchannel testthread}
+
+# --- === *** ###########################
+# method read
+
+test iortrans.tf-4.1 {chan read, transform call and return} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return snarf
+ }
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [read $c 10]
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{read rt* {test data
+}} snarf}
+
+test iortrans.tf-4.2 {chan read, for non-readable channel} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track; note MUST_NOT_HAPPEN
+ }
+ set c [chan push [tempchan w] foo]
+ notes [inthread $c {
+ note [catch {[read $c 2]} msg]; note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {1 {channel "file*" wasn't opened for reading}}
+test iortrans.tf-4.3 {chan read, error return} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -code error BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {read $c 2} msg]; note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 BOOM!} \
+ -constraints {testchannel testthread}
+test iortrans.tf-4.4 {chan read, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -code break BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {read $c 2} msg]; note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 *bad code*} \
+ -constraints {testchannel testthread}
+test iortrans.tf-4.5 {chan read, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -code continue BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {read $c 2} msg]; note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 *bad code*} \
+ -constraints {testchannel testthread}
+test iortrans.tf-4.6 {chan read, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -code 777 BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {read $c 2} msg]; note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 *bad code*} \
+ -constraints {testchannel testthread}
+
+test iortrans.tf-4.7 {chan read, level is squashed} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -level 55 -code 777 BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} \
+ -constraints {testchannel testthread}
+
+# --- === *** ###########################
+# method write
+
+test iortrans.tf-5.1 {chan write, regular write} -match glob -body {
+ set res {}
+ proc foo {args} { oninit; onfinal; track ; return transformresult }
+ set c [chan push [tempchan] foo]
+ inthread $c {
+ puts -nonewline $c snarf; flush $c
+ close $c
+ } c
+ note [tempview]
+ tempdone
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{write rt* snarf} transformresult}
+test iortrans.tf-5.2 {chan write, no write is ok, no change to file} -match glob -body {
+ set res {}
+ proc foo {args} { oninit; onfinal; track ; return {} }
+ set c [chan push [tempchan] foo]
+ inthread $c {
+ puts -nonewline $c snarfsnarfsnarf; flush $c
+ close $c
+ } c
+ note [tempview];# This has to show the original data, as nothing was written
+ tempdone
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {{write rt* snarfsnarfsnarf} {test data}}
+test iortrans.tf-5.3 {chan write, failed write} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code error FAIL!}
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ puts -nonewline $c snarfsnarfsnarf
+ note [catch {flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {{write rt* snarfsnarfsnarf} 1 FAIL!}
+test iortrans.tf-5.4 {chan write, non-writable channel} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}
+ set c [chan push [tempchan r] foo]
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {1 {channel "file*" wasn't opened for writing}}
+test iortrans.tf-5.5 {chan write, failed write, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code error BOOM!}
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} \
+ -constraints {testchannel testthread}
+test iortrans.tf-5.6 {chan write, failed write, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; error BOOM!}
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+
+test iortrans.tf-5.7 {chan write, failed write, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code break BOOM!}
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \
+ -constraints {testchannel testthread}
+test iortrans.tf-5.8 {chan write, failed write, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code continue BOOM!}
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \
+ -constraints {testchannel testthread}
+test iortrans.tf-5.9 {chan write, failed write, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!}
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \
+ -constraints {testchannel testthread}
+test iortrans.tf-5.10 {chan write, failed write, level is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!}
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt]
+ note $msg
+ noteOpts $opt
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} \
+ -constraints {testchannel testthread}
+
+
+# --- === *** ###########################
+# method limit?, drain (via read)
+
+test iortrans.tf-6.1 {chan read, read limits} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit limit?; onfinal; track ; onread
+ return 6
+ }
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [read $c 10]
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{limit? rt*} {read rt* {test d}} {limit? rt*} {read rt* {ata
+}} {limit? rt*} @@} -constraints {testchannel testthread}
+test iortrans.tf-6.2 {chan read, read transform drain on eof} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit drain; onfinal; track ; onread ; ondrain
+ return
+ }
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [read $c]
+ note [close $c]
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} {drain rt*} @<> {}} -constraints {testchannel testthread}
+
+# --- === *** ###########################
+# method clear (via puts, seek)
+
+test iortrans.tf-7.1 {chan write, write clears read buffers} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit clear; onfinal; track ; onclear
+ return transformresult
+ }
+ set c [chan push [tempchan] foo]
+ inthread $c {
+ puts -nonewline $c snarf; flush $c
+ close $c
+ } c
+ tempdone
+ rename foo {}
+ set res
+} -result {{clear rt*} {write rt* snarf}} -constraints {testchannel testthread}
+test iortrans.tf-7.2 {seek clears read buffers} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit clear; onfinal; track
+ return
+ }
+ set c [chan push [tempchan] foo]
+ inthread $c {
+ seek $c 2
+ close $c
+ } c
+ tempdone
+ rename foo {}
+ set res
+} -result {{clear rt*}} -constraints {testchannel testthread}
+test iortrans.tf-7.3 {clear, any result is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit clear; onfinal; track
+ return -code error "X"
+ }
+ set c [chan push [tempchan] foo]
+ inthread $c {
+ seek $c 2
+ close $c
+ } c
+ tempdone
+ rename foo {}
+ set res
+} -result {{clear rt*}} -constraints {testchannel testthread}
+
+# --- === *** ###########################
+# method flush (via seek, close)
+
+test iortrans-8.1 {seek flushes write buffers, ignores data} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit flush; onfinal; track
+ return X
+ }
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ # Flush, no writing
+ seek $c 2
+ # The close flushes again, this modifies the file!
+ note | ; note [close $c] ; note |
+ # 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]
+ note [tempview]
+ tempdone
+ rename foo {}
+ set res
+} -result {{flush rt*} {flush rt*} | {} | {teXt data}} -constraints {testchannel testthread}
+
+test iortrans-8.2 {close flushes write buffers, writes data} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit flush; track ; onfinal
+ return .flushed.
+ }
+ set c [chan push [tempchan] foo]
+ inthread $c {
+ close $c
+ } c
+ note [tempview]
+ tempdone
+ rename foo {}
+ set res
+} -result {{flush rt*} {finalize rt*} .flushed.} -constraints {testchannel testthread}
+
+
+# --- === *** ###########################
+# 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} -match glob -body {
+
+ #puts <<$tcltest::mainThread>>main
+ set tida [testthread create];#puts <<$tida>>
+ set tidb [testthread create];#puts <<$tidb>>
+
+ # Set up channel in thread
+ testthread send $tida $helperscript
+ set chan [testthread send $tida {
+ proc foo {args} {oninit clear drain flush limit? read write; onfinal; track; return}
+ set chan [chan push [tempchan] foo]
+ fconfigure $chan -buffering none
+ set chan
+ }]
+
+ # Move channel to 2nd thread, transform goes with it.
+ testthread send $tida [list testchannel cut $chan]
+ testthread send $tidb [list testchannel splice $chan]
+
+ # Kill origin thread, then access channel from 2nd thread.
+ testthread send -async $tida {testthread exit}
+ after 100
+
+ set res {}
+ lappend res [catch {testthread 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
+ set res
+ # The 'tell' is ok, as it passed through the transform to the base
+ # channel without invoking the transform handler.
+
+} -constraints {testchannel testthread} \
+ -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
+
+test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} -match glob -body {
+
+ #puts <<$tcltest::mainThread>>main
+ set tida [testthread create];#puts <<$tida>>
+ set tidb [testthread create];#puts <<$tidb>>
+
+ # Set up channel in thread
+ set chan [testthread send $tida $helperscript]
+ set chan [testthread send $tida {
+ proc foo {args} {
+ oninit clear drain flush limit? read write; onfinal; track;
+ # destroy thread during channel access
+ testthread exit
+ return}
+ set chan [chan push [tempchan] foo]
+ fconfigure $chan -buffering none
+ set chan
+ }]
+
+ # Move channel to 2nd thread, transform goes with it.
+ testthread send $tida [list testchannel cut $chan]
+ testthread 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 {
+ # 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]
+ }
+ vwait ::res
+
+ tcltest::threadReap
+ set res
+} -constraints {testchannel testthread} \
+ -result {Owner lost}
+
+# ### ### ### ######### ######### #########
+
+# ### ### ### ######### ######### #########
+
+rename track {}
+cleanupTests
+return