diff options
Diffstat (limited to 'tests/ioTrans.test')
| -rw-r--r-- | tests/ioTrans.test | 1463 |
1 files changed, 1463 insertions, 0 deletions
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 |