# -*- 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 # # # 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