# -*- 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::*
}
# Custom constraints used in this file
testConstraint testchannel [llength [info commands testchannel]]
testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
# 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*]
} -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 {}
} -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 {}
} -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 {}
} -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 {}
} -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 {}
} -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 {}
} -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 {}
} -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 {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}}
# --- === *** ###########################
# method read (via read)
test iortrans-4.1 {chan read, transform call and return} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize
handle.finalize
lappend ::res $args
return snarf
}
set c [chan push [tempchan] foo]
lappend res [read $c 10]
} -cleanup {
tempdone
rename foo {}
} -result {{read rt* {test data
}} snarf}
test iortrans-4.2 {chan read, for non-readable channel} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize
handle.finalize
lappend ::res $args MUST_NOT_HAPPEN
}
set c [chan push [tempchan w] foo]
lappend res [catch {read $c 2} msg] $msg
} -cleanup {
tempdone
rename foo {}
} -result {1 {channel "file*" wasn't opened for reading}}
test iortrans-4.3 {chan read, error return} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize
handle.finalize
lappend ::res $args
return -code error BOOM!
}
set c [chan push [tempchan] foo]
lappend res [catch {read $c 2} msg] $msg
} -cleanup {
tempdone
rename foo {}
} -result {{read rt* {test data
}} 1 BOOM!}
test iortrans-4.4 {chan read, break return is error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize
handle.finalize
lappend ::res $args
return -code break BOOM!
}
set c [chan push [tempchan] foo]
lappend res [catch {read $c 2} msg] $msg
} -cleanup {
tempdone
rename foo {}
} -result {{read rt* {test data
}} 1 *bad code*}
test iortrans-4.5 {chan read, continue return is error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize
handle.finalize
lappend ::res $args
return -code continue BOOM!
}
set c [chan push [tempchan] foo]
lappend res [catch {read $c 2} msg] $msg
} -cleanup {
tempdone
rename foo {}
} -result {{read rt* {test data
}} 1 *bad code*}
test iortrans-4.6 {chan read, custom return is error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize
handle.finalize
lappend ::res $args
return -code 777 BOOM!
}
set c [chan push [tempchan] foo]
lappend res [catch {read $c 2} msg] $msg
} -cleanup {
tempdone
rename foo {}
} -result {{read rt* {test data
}} 1 *bad code*}
test iortrans-4.7 {chan read, level is squashed} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize
handle.finalize
lappend ::res $args
return -level 55 -code 777 BOOM!
}
set c [chan push [tempchan] foo]
lappend res [catch {read $c 2} msg opt] $msg
noteOpts $opt
} -cleanup {
tempdone
rename foo {}
} -result {{read rt* {test data
}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}}
test iortrans-4.8 {chan read, read, bug 2921116} -setup {
set res {}
} -match glob -body {
proc foo {fd args} {
handle.initialize
handle.finalize
lappend ::res $args
# Kill and recreate transform while it is operating
chan pop $fd
chan push $fd [list foo $fd]
}
set c [chan push [set c [tempchan]] [list foo $c]]
lappend res [read $c]
#lappend res [gets $c]
} -cleanup {
tempdone
rename foo {}
} -result {{read rt* {test data
}} file*}
test iortrans-4.9 {chan read, gets, bug 2921116} -setup {
set res {}
} -match glob -body {
proc foo {fd args} {
handle.initialize
handle.finalize
lappend ::res $args
# Kill and recreate transform while it is operating
chan pop $fd
chan push $fd [list foo $fd]
}
set c [chan push [set c [tempchan]] [list foo $c]]
lappend res [gets $c]
} -cleanup {
tempdone
rename foo {}
} -result {{read rt* {test data
}} file*}
# --- === *** ###########################
# method write (via puts)
test iortrans-5.1 {chan write, regular write} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize
handle.finalize
lappend ::res $args
return transformresult
}
set c [chan push [tempchan] foo]
puts -nonewline $c snarf
flush $c
close $c
lappend res [tempview]
} -cleanup {
tempdone
rename foo {}
} -result {{write rt* snarf} transformresult}
test iortrans-5.2 {chan write, no write is ok, no change to file} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize
handle.finalize
lappend ::res $args
return
}
set c [chan push [tempchan] foo]
puts -nonewline $c snarfsnarfsnarf
flush $c
close $c
lappend res [tempview]; # This has to show the original data, as nothing was written
} -cleanup {
tempdone
rename foo {}
} -result {{write rt* snarfsnarfsnarf} {test data}}
test iortrans-5.3 {chan write, failed write} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize
handle.finalize
lappend ::res $args
return -code error FAIL!
}
set c [chan push [tempchan] foo]
puts -nonewline $c snarfsnarfsnarf
lappend res [catch {flush $c} msg] $msg
} -cleanup {
tempdone
rename foo {}
} -result {{write rt* snarfsnarfsnarf} 1 FAIL!}
test iortrans-5.4 {chan write, non-writable channel} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize
handle.finalize
lappend ::res $args MUST_NOT_HAPPEN
return
}
set c [chan push [tempchan r] foo]
lappend res [catch {
puts -nonewline $c snarfsnarfsnarf
flush $c
} msg] $msg
} -cleanup {
close $c
tempdone
rename foo {}
} -result {1 {channel "file*" wasn't opened for writing}}
test iortrans-5.5 {chan write, failed write, error return} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize
handle.finalize
lappend ::res $args
return -code error BOOM!
}
set c [chan push [tempchan] foo]
lappend res [catch {
puts -nonewline $c snarfsnarfsnarf
flush $c
} msg] $msg
} -cleanup {
tempdone
rename foo {}
} -result {{write rt* snarfsnarfsnarf} 1 BOOM!}
test iortrans-5.6 {chan write, failed write, error return} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize
handle.finalize
lappend ::res $args
error BOOM!
}
set c [chan push [tempchan] foo]
lappend res {*}[catch {
puts -nonewline $c snarfsnarfsnarf
flush $c
} msg] $msg
} -cleanup {
tempdone
rename foo {}
} -result {{write rt* snarfsnarfsnarf} 1 BOOM!}
test iortrans-5.7 {chan write, failed write, break return is error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize
handle.finalize
lappend ::res $args
return -code break BOOM!
}
set c [chan push [tempchan] foo]
lappend res [catch {
puts -nonewline $c snarfsnarfsnarf
flush $c
} msg] $msg
} -cleanup {
tempdone
rename foo {}
} -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
test iortrans-5.8 {chan write, failed write, continue return is error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize
handle.finalize
lappend ::res $args
return -code continue BOOM!
}
set c [chan push [tempchan] foo]
lappend res [catch {
puts -nonewline $c snarfsnarfsnarf
flush $c
} msg] $msg
} -cleanup {
tempdone
rename foo {}
} -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
test iortrans-5.9 {chan write, failed write, custom return is error} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize
handle.finalize
lappend ::res $args
return -code 777 BOOM!
}
set c [chan push [tempchan] foo]
lappend res [catch {
puts -nonewline $c snarfsnarfsnarf
flush $c
} msg] $msg
} -cleanup {
tempdone
rename foo {}
} -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
test iortrans-5.10 {chan write, failed write, level is ignored} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize
handle.finalize
lappend ::res $args
return -level 55 -code 777 BOOM!
}
set c [chan push [tempchan] foo]
lappend res [catch {
puts -nonewline $c snarfsnarfsnarf
flush $c
} msg opt] $msg
noteOpts $opt
} -cleanup {
tempdone
rename foo {}
} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline * -errorinfo *bad code*subcommand "write"*}}
test iortrans-5.11 {chan write, bug 2921116} -match glob -setup {
set res {}
set level 0
} -body {
proc foo {fd args} {
handle.initialize
handle.finalize
lappend ::res $args
# pop - invokes flush - invokes 'foo write' - infinite recursion - stop it
global level
if {$level} {
return
}
incr level
# Kill and recreate transform while it is operating
chan pop $fd
chan push $fd [list foo $fd]
}
set c [chan push [set c [tempchan]] [list foo $c]]
lappend res [puts -nonewline $c abcdef]
lappend res [flush $c]
} -cleanup {
tempdone
rename foo {}
} -result {{} {write rt* abcdef} {write rt* abcdef} {}}
# --- === *** ###########################
# method limit?, drain (via read)
test iortrans-6.1 {chan read, read limits} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize limit?
handle.finalize
lappend ::res $args
handle.read
return 6
}
set c [chan push [tempchan] foo]
lappend res [read $c 10]
} -cleanup {
tempdone
rename foo {}
} -result {{limit? rt*} {read rt* {test d}} {limit? rt*} {read rt* {ata
}} {limit? rt*} @@}
test iortrans-6.2 {chan read, read transform drain on eof} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize drain
handle.finalize
lappend ::res $args
handle.read
handle.drain
return
}
set c [chan push [tempchan] foo]
lappend res [read $c]
lappend res [close $c]
} -cleanup {
tempdone
rename foo {}
} -result {{read rt* {test data
}} {drain rt*} @<> {}}
# --- === *** ###########################
# method clear (via puts, seek)
test iortrans-7.1 {chan write, write clears read buffers} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize clear
handle.finalize
lappend ::res $args
handle.clear
return transformresult
}
set c [chan push [tempchan] foo]
puts -nonewline $c snarf
flush $c
return $res
} -cleanup {
tempdone
rename foo {}
} -result {{clear rt*} {write rt* snarf}}
test iortrans-7.2 {seek clears read buffers} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize clear
handle.finalize
lappend ::res $args
return
}
set c [chan push [tempchan] foo]
seek $c 2
return $res
} -cleanup {
tempdone
rename foo {}
} -result {{clear rt*}}
test iortrans-7.3 {clear, any result is ignored} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize clear
handle.finalize
lappend ::res $args
return -code error "X"
}
set c [chan push [tempchan] foo]
seek $c 2
return $res
} -cleanup {
tempdone
rename foo {}
} -result {{clear rt*}}
test iortrans-7.4 {chan clear, bug 2921116} -match glob -setup {
set res {}
} -body {
proc foo {fd args} {
handle.initialize clear
handle.finalize
lappend ::res $args
# Kill and recreate transform while it is operating
chan pop $fd
chan push $fd [list foo $fd]
}
set c [chan push [set c [tempchan]] [list foo $c]]
seek $c 2
return $res
} -cleanup {
tempdone
rename foo {}
} -result {{clear rt*}}
# --- === *** ###########################
# method flush (via seek, close)
test iortrans-8.1 {seek flushes write buffers, ignores data} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize flush
handle.finalize
lappend ::res $args
return X
}
set c [chan push [tempchan] foo]
# Flush, no writing
seek $c 2
# The close flushes again, this modifies the file!
lappend res |
lappend res [close $c] | [tempview]
} -cleanup {
tempdone
rename foo {}
} -result {{flush rt*} | {flush rt*} {} | {teXt data}}
test iortrans-8.2 {close flushes write buffers, writes data} -setup {
set res {}
} -match glob -body {
proc foo {args} {
handle.initialize flush
lappend ::res $args
handle.finalize
return .flushed.
}
set c [chan push [tempchan] foo]
close $c
lappend res [tempview]
} -cleanup {
tempdone
rename foo {}
} -result {{flush rt*} {finalize rt*} .flushed.}
test iortrans-8.3 {chan flush, bug 2921116} -match glob -setup {
set res {}
} -body {
proc foo {fd args} {
handle.initialize flush
handle.finalize
lappend ::res $args
# Kill and recreate transform while it is operating
chan pop $fd
chan push $fd [list foo $fd]
}
set c [chan push [set c [tempchan]] [list foo $c]]
seek $c 2
set res
} -cleanup {
tempdone
rename foo {}
} -result {{flush rt*}}
# --- === *** ###########################
# method watch - removed from TIP (rev 1.12+)
# --- === *** ###########################
# method event - removed from TIP (rev 1.12+)
# --- === *** ###########################
# 'Pull the rug' tests. Create channel in a interpreter A, move to other
# interpreter B, destroy the origin interpreter (A) before or during access
# from B. Must not crash, must return proper errors.
test iortrans-11.0 {origin interpreter of moved transform gone} -setup {
set ida [interp create]; #puts <<$ida>>
set idb [interp create]; #puts <<$idb>>
# Magic to get the test* commands in the slaves
load {} Tcltest $ida
load {} Tcltest $idb
} -constraints {testchannel} -match glob -body {
# Set up channel and transform in interpreter
interp eval $ida $helperscript
interp eval $ida [list ::variable tempchan [tempchan]]
interp transfer {} $::tempchan $ida
set chan [interp eval $ida {
variable tempchan
proc foo {args} {
handle.initialize clear drain flush limit? read write
handle.finalize
lappend ::res $args
return
}
set chan [chan push $tempchan foo]
fconfigure $chan -buffering none
set chan
}]
# Move channel to 2nd interpreter, transform goes with it.
interp eval $ida [list testchannel cut $chan]
interp eval $idb [list testchannel splice $chan]
# Kill origin interpreter, then access channel from 2nd interpreter.
interp delete $ida
set res {}
lappend res \
[catch {interp eval $idb [list puts $chan shoo]} msg] $msg \
[catch {interp eval $idb [list tell $chan]} msg] $msg \
[catch {interp eval $idb [list seek $chan 1]} msg] $msg \
[catch {interp eval $idb [list gets $chan]} msg] $msg \
[catch {interp eval $idb [list close $chan]} msg] $msg
#lappend res [interp eval $ida {set res}]
# actions: clear|write|clear|write|clear|flush|limit?|drain|flush
# The 'tell' is ok, as it passed through the transform to the base channel
# without invoking the transform handler.
} -cleanup {
tempdone
} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup {
set ida [interp create]; #puts <<$ida>>
set idb [interp create]; #puts <<$idb>>
# Magic to get the test* commands in the slaves
load {} Tcltest $ida
load {} Tcltest $idb
} -constraints {testchannel impossible} -match glob -body {
# Set up channel in thread
set chan [interp eval $ida $helperscript]
set chan [interp eval $ida {
proc foo {args} {
handle.initialize clear drain flush limit? read write
handle.finalize
lappend ::res $args
# Destroy interpreter during channel access. Actually not
# possible for an interp to destroy itself.
interp delete {}
return}
set chan [chan push [tempchan] foo]
fconfigure $chan -buffering none
set chan
}]
# Move channel to 2nd thread, transform goes with it.
interp eval $ida [list testchannel cut $chan]
interp eval $idb [list testchannel splice $chan]
# Run access from interpreter B, this will give us a synchronous response.
interp eval $idb [list set chan $chan]
interp eval $idb [list set mid $tcltest::mainThread]
set res [interp eval $idb {
# Wait a bit, give the main thread the time to start its event loop to
# wait for the response from B
after 50
catch { puts $chan shoo } res
set res
}]
} -cleanup {
tempdone
} -result {Owner lost}
test iortrans-11.2 {delete interp of reflected transform} -setup {
interp create slave
# Magic to get the test* commands into the slave
load {} Tcltest slave
} -constraints {testchannel} -body {
# Get base channel into the slave
set c [tempchan]
testchannel cut $c
interp eval slave [list testchannel splice $c]
interp eval slave [list set c $c]
slave eval {
proc no-op args {}
proc driver {c sub args} {
return {initialize finalize read write}
}
set t [chan push $c [list driver $c]]
chan event $c readable no-op
}
interp delete slave
} -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