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