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