diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/chanio.test | 523 | ||||
| -rw-r--r-- | tests/ioTrans.test | 1676 | ||||
| -rw-r--r-- | tests/iogt.test | 477 |
3 files changed, 1373 insertions, 1303 deletions
diff --git a/tests/chanio.test b/tests/chanio.test index f15bad6..b1c4e8a 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: chanio.test,v 1.25 2010/11/21 12:12:36 dkf Exp $ +# RCS: @(#) $Id: chanio.test,v 1.26 2010/11/24 11:56:57 dkf Exp $ if {[catch {package require tcltest 2}]} { chan puts stderr "Skipping tests in [info script]. tcltest 2 required." @@ -41,12 +41,12 @@ namespace eval ::tcl::test::io { testConstraint testmainthread [llength [info commands testmainthread]] testConstraint testthread [llength [info commands testthread]] - # You need a *very* special environment to do some tests. In - # particular, many file systems do not support large-files... + # You need a *very* special environment to do some tests. In particular, + # many file systems do not support large-files... testConstraint largefileSupport 0 - # some tests can only be run is umask is 2 - # if "umask" cannot be run, the tests will be skipped. + # some tests can only be run is umask is 2 if "umask" cannot be run, the + # tests will be skipped. set umaskValue 0 testConstraint umask [expr {![catch {set umaskValue [scan [exec /bin/sh -c umask] %o]}]}] @@ -92,6 +92,11 @@ namespace eval ::tcl::test::io { chan close $f return $a } + + # Wrapper round butt-ugly pipe syntax + proc openpipe {{mode r+} args} { + open "|[list [interpreter] {*}$args]" $mode + } test chan-io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} { # no test, need to cause an async error. @@ -184,9 +189,9 @@ test chan-io-2.2 {WriteBytes: savedLF > 0} { lappend x [contents $path(test1)] } [list "123456789012345\r" "123456789012345\r\n12"] test chan-io-2.3 {WriteBytes: flush on line} -body { - # Tcl "line" buffering has weird behavior: if current buffer contains - # a \n, entire buffer gets flushed. Logical behavior would be to flush - # only up to the \n. + # Tcl "line" buffering has weird behavior: if current buffer contains a + # \n, entire buffer gets flushed. Logical behavior would be to flush only + # up to the \n. set f [open $path(test1) w] chan configure $f -encoding binary -buffering line -translation crlf chan puts -nonewline $f "\n12" @@ -223,9 +228,9 @@ test chan-io-3.2 {WriteChars: compatibility with WriteBytes: savedLF > 0} { lappend x [contents $path(test1)] } [list "123456789012345\r" "123456789012345\r\n12"] test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} -body { - # Tcl "line" buffering has weird behavior: if current buffer contains - # a \n, entire buffer gets flushed. Logical behavior would be to flush - # only up to the \n. + # Tcl "line" buffering has weird behavior: if current buffer contains a + # \n, entire buffer gets flushed. Logical behavior would be to flush only + # up to the \n. set f [open $path(test1) w] chan configure $f -encoding ascii -buffering line -translation crlf chan puts -nonewline $f "\n12" @@ -441,7 +446,7 @@ test chan-io-6.6 {Tcl_GetsObj: loop test} -body { } -result [list 256 $a] test chan-io-6.7 {Tcl_GetsObj: error in input} -constraints {stdio openpipe} -body { # if (FilterInputBytes(chanPtr, &gs) != 0) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan puts -nonewline $f "hi\nwould" chan flush $f chan gets $f @@ -702,7 +707,7 @@ test chan-io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} -setup { set x "" } -constraints {stdio testchannel openpipe fileevent} -body { # (FilterInputBytes() != 0) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {crlf lf} -buffering none chan puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r" chan configure $f -buffersize 16 @@ -842,7 +847,7 @@ test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup { set x "" } -constraints {stdio testchannel openpipe fileevent} -body { # if (chanPtr->flags & INPUT_SAW_CR) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" chan configure $f -buffersize 16 @@ -860,7 +865,7 @@ test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} -setup { set x "" } -constraints {stdio testchannel openpipe fileevent} -body { # not (*eol == '\n') - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" chan configure $f -buffersize 16 @@ -878,7 +883,7 @@ test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} -setup set x "" } -constraints {stdio testchannel openpipe fileevent} -body { # Tcl_ExternalToUtf() - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none chan configure $f -encoding unicode chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" @@ -896,7 +901,7 @@ test chan-io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eo set x "" } -constraints {stdio testchannel openpipe fileevent} -body { # memmove() - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" chan configure $f -buffersize 16 @@ -1013,7 +1018,7 @@ test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} -se update variable x {} } -constraints {stdio openpipe fileevent} -body { - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -buffering none chan puts -nonewline $f "foobar" chan configure $f -blocking 0 @@ -1080,7 +1085,7 @@ test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup { test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup { variable x "" } -constraints {stdio openpipe fileevent} -body { - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -encoding binary -buffering none chan puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" chan configure $f -encoding shiftjis -blocking 0 @@ -1115,7 +1120,7 @@ test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup { variable x {} } -constraints {stdio testchannel openpipe fileevent} -body { # not (bufPtr->nextPtr == NULL) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation lf -encoding ascii -buffering none chan puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz" chan event $f read [namespace code { @@ -1132,7 +1137,7 @@ test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup { } -result {-1 {} 42 15 123456789012345 25} test chan-io-8.3 {PeekAhead: no cached data available} -constraints {stdio testchannel openpipe fileevent} -body { # (bytesLeft == 0) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} chan puts -nonewline $f "abcdefghijklmno\r" chan flush $f @@ -1161,7 +1166,7 @@ test chan-io-8.4 {PeekAhead: cached data available in this buffer} -body { unset a test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {stdio testchannel openpipe fileevent} -body { # (bufPtr->nextAdded < bufPtr->length) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} chan puts -nonewline $f "abcdefghijklmno\r" chan flush $f @@ -1172,7 +1177,7 @@ test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {st } -result {15 abcdefghijklmno 1} test chan-io-8.6 {PeekAhead: change to non-blocking mode} -constraints {stdio testchannel openpipe fileevent} -body { # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} -buffersize 16 chan puts -nonewline $f "abcdefghijklmno\r" chan flush $f @@ -1185,7 +1190,7 @@ test chan-io-8.7 {PeekAhead: cleanup} -setup { set x "" } -constraints {stdio testchannel openpipe fileevent} -body { # Make sure bytes are removed from buffer. - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} -buffering none chan puts -nonewline $f "abcdefghijklmno\r" # here @@ -1336,7 +1341,7 @@ test chan-io-12.4 {ReadChars: split-up char} -setup { variable x {} } -constraints {stdio testchannel openpipe fileevent} -body { # (srcRead == 0) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -encoding binary -buffering none -buffersize 16 chan puts -nonewline $f "123456789012345\x96" chan configure $f -encoding shiftjis -blocking 0 @@ -1363,7 +1368,7 @@ test chan-io-12.5 {ReadChars: chan events on partial characters} -setup { chan gets stdin; chan puts -nonewline "\x89" chan gets stdin; chan puts -nonewline "\xa6" } test1] - set f [open "|[list [interpreter] $path(test1)]" r+] + set f [openpipe r+ $path(test1)] chan event $f readable [namespace code { lappend x [chan read $f] if {[chan eof $f]} { @@ -1452,7 +1457,7 @@ test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} -setup } -constraints {stdio testchannel openpipe fileevent} -body { # (chanPtr->flags & INPUT_SAW_CR) # This test may fail on slower machines. - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -blocking 0 -buffering none -translation {auto lf} chan event $f read [namespace code { lappend x [chan read $f] [testchannel queuedcr $f] @@ -1607,7 +1612,8 @@ test chan-io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints {exec} -b chan puts $f [list open $path(test1) r]] chan puts $f "set f2 \[[list open $path(test2) w]]" chan puts $f "set f3 \[[list open $path(test3) w]]" - chan puts $f { chan puts stdout [chan gets stdin] + chan puts $f { + chan puts stdout [chan gets stdin] chan puts stdout $f2 chan puts stderr $f3 chan close $f @@ -1679,7 +1685,7 @@ test chan-io-14.8 {reuse of stdio special channels} -setup { chan puts [chan gets $f] } chan close $f - set f [open "|[list [interpreter] $path(script)]" r] + set f [openpipe r $path(script)] chan gets $f } -cleanup { chan close $f @@ -1699,7 +1705,7 @@ test chan-io-14.9 {reuse of stdio special channels} -setup { chan puts [chan gets $f] } chan close $f - set f [open "|[list [interpreter] $path(script) [array get path]]" r] + set f [openpipe r $path(script) [array get path]] chan gets $f } -cleanup { chan close $f @@ -1773,8 +1779,7 @@ test chan-io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { } else { lappend l "very broken: $f found after being chan closed" } - string equal [string tolower $l] \ - [list 1 "can not find channel named \"$f\""] + string equal $l [list 1 "can not find channel named \"$f\""] } -result 1 test chan-io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { file delete -force $path(test1) @@ -1795,8 +1800,7 @@ test chan-io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { } else { lappend l "very broken: $f found after being chan closed" } - string equal [string tolower $l] \ - [list 1 2 1 1 "can not find channel named \"$f\""] + string equal $l [list 1 2 1 1 "can not find channel named \"$f\""] } -result 1 test chan-io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { file delete $path(test1) @@ -1815,8 +1819,7 @@ test chan-io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { } else { lappend l "very broken: $f found after being chan closed" } - string equal [string tolower $l] \ - [list 1 2 1 "can not find channel named \"$f\""] + string equal $l [list 1 2 1 "can not find channel named \"$f\""] } -result 1 test chan-io-19.1 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} { @@ -1845,8 +1848,7 @@ test chan-io-19.4 {Tcl_CreateChannel, insertion into channel table} -setup { } else { lappend l "very broken: $f found after being chan closed" } - string equal [string tolower $l] \ - [list 0 "can not find channel named \"$f\""] + string equal $l [list 0 "can not find channel named \"$f\""] } -result 1 test chan-io-20.1 {Tcl_CreateChannel: initial settings} -setup { @@ -1886,7 +1888,7 @@ test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup { chan puts stderr [chan configure stdout -buffersize] } chan close $f - set f [open "|[list [interpreter] $path(script)]"] + set f [openpipe r $path(script)] chan close $f } -cleanup { removeFile $path(stdout) @@ -1958,7 +1960,7 @@ test chan-io-25.2 {Tcl_GetChannelHandle, output} -setup { test chan-io-26.1 {Tcl_GetChannelInstanceData} -body { # "pid" command uses Tcl_GetChannelInstanceData # Don't care what pid is (but must be a number), just want to exercise it. - set f [open "|[list [interpreter] << exit]"] + set f [openpipe r << exit] pid $f } -constraints {stdio openpipe} -cleanup { chan close $f @@ -2053,7 +2055,7 @@ test chan-io-27.6 {FlushChannel, async flushing, async chan close} -setup { } set f [open $path(output) w] chan close $f - set f [open "|[list [interpreter] $path(pipe)]" w] + set f [openpipe w $path(pipe)] chan configure $f -blocking off chan puts -nonewline $f $x chan close $f @@ -2128,7 +2130,7 @@ test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} - } set f [open $path(output) w] chan close $f - set f [open "|[list [interpreter] pipe]" r+] + set f [openpipe r+ $path(pipe)] chan configure $f -blocking off -eofchar {} chan puts -nonewline $f $x chan close $f @@ -2166,7 +2168,7 @@ test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup { chan puts [testchannel open] } chan close $f - set f [open "|[list [interpreter] $path(script)]" r] + set f [openpipe r $path(script)] set l [chan gets $f] chan close $f lsort $l @@ -2174,27 +2176,28 @@ test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup { test chan-io-28.6 {Tcl_CloseEx (half-close) pipe} -setup { set cat [makeFile { fconfigure stdout -buffering line - while {[gets stdin line]>=0} {puts $line} + while {[gets stdin line] >= 0} {puts $line} puts DONE exit 0 } cat.tcl] + variable done } -body { - set ::ff [open "|[list [interpreter] $cat]" r+] - puts $::ff Hey - close $::ff w - set timer [after 1000 {set ::done Failed}] - set ::acc {} - fileevent $::ff readable { - if {[gets $::ff line]<0} { - set ::done Succeeded + set ff [openpipe r+ $cat] + puts $ff Hey + close $ff w + set timer [after 1000 [namespace code {set done Failed}]] + set acc {} + fileevent $ff readable [namespace code { + if {[gets $ff line] < 0} { + set done Succeeded } else { - lappend ::acc $line + lappend acc $line } - } - vwait ::done + }] + vwait [namespace which -variable done] after cancel $timer - close $::ff r - list $::done $::acc + close $ff r + list $done $acc } -cleanup { removeFile cat.tcl } -result {Succeeded {Hey DONE}} @@ -2205,31 +2208,31 @@ test chan-io-28.7 {Tcl_CloseEx (half-close) socket} -setup { puts [lindex [fconfigure $s -sockname] 2] flush stdout vwait ::sok - fconfigure $::sok -buffering line - while {[gets $::sok line]>=0} {puts $::sok $line} - puts $::sok DONE + fconfigure $sok -buffering line + while {[gets $sok line]>=0} {puts $sok $line} + puts $sok DONE exit 0 } echo.tcl] } -body { - set ::ff [open "|[list [interpreter] $echo]" r] - gets $::ff port - set ::s [socket 127.0.0.1 $port] - puts $::s Hey - close $::s w - set timer [after 1000 {set ::done Failed}] - set ::acc {} - fileevent $::s readable { - if {[gets $::s line]<0} { - set ::done Succeeded + set ff [openpipe r $echo] + gets $ff port + set s [socket 127.0.0.1 $port] + puts $s Hey + close $s w + set timer [after 1000 [namespace code {set ::done Failed}]] + set acc {} + fileevent $s readable [namespace code { + if {[gets $s line]<0} { + set done Succeeded } else { - lappend ::acc $line + lappend acc $line } - } - vwait ::done + }] + vwait [namespace which -variable done] after cancel $timer - close $::s r - close $::ff - list $::done $::acc + close $s r + close $ff + list $done $acc } -cleanup { removeFile echo.tcl } -result {Succeeded {Hey DONE}} @@ -2380,13 +2383,13 @@ test chan-io-29.12 {Tcl_WriteChars on a pipe} -setup { } } chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r] + set f1 [openpipe r $path(pipe)] set f2 [open $path(longfile) r] set y ok for {set x 0} {$x < 10} {incr x} { set l1 [chan gets $f1] set l2 [chan gets $f2] - if {"$l1" ne "$l2"} { + if {$l1 ne $l2} { set y broken:$x } } @@ -2406,20 +2409,20 @@ test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} -setup { } chan close $f1 set y ok - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan configure $f1 -buffering line set f2 [open $path(longfile) r] set line [chan gets $f2] chan puts $f1 $line set backline [chan gets $f1] - if {"$line" ne "$backline"} { - set y broken + if {$line ne $backline} { + set y broken1 } set line [chan gets $f2] chan puts $f1 $line set backline [chan gets $f1] - if {"$line" ne "$backline"} { - set y broken + if {$line ne $backline} { + set y broken2 } return $y } -cleanup { @@ -2450,7 +2453,7 @@ test chan-io-29.15 {Tcl_Flush, channel not open for writing} -setup { catch {chan close $fd} } -match glob -result {channel "*" wasn't opened for writing} test chan-io-29.16 {Tcl_Flush on pipe opened only for reading} -setup { - set fd [open "|[list [interpreter] cat longfile]" r] + set fd [openpipe r cat longfile] } -constraints {stdio openpipe} -body { chan flush $fd } -returnCodes error -cleanup { @@ -2533,7 +2536,7 @@ test chan-io-29.21 {Tcl_Flush to pipe} -setup { chan puts $f1 {set cnt [string length $x]} chan puts $f1 {chan puts "read $cnt characters"} chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello chan flush $f1 chan gets $f1 @@ -2554,7 +2557,7 @@ test chan-io-29.22 {Tcl_Flush called at other end of pipe} -setup { chan flush stdout } chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] set x "" lappend x [chan gets $f1] lappend x [chan gets $f1] @@ -2575,7 +2578,7 @@ test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} -setup { chan puts bye } chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] set x "" lappend x [chan gets $f1] lappend x [chan gets $f1] @@ -2604,7 +2607,7 @@ test chan-io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} -setup { test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} -setup { file delete $path(test3) } -constraints {stdio openpipe fileevent} -body { - set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w] + set f [openpipe w $path(cat) | [interpreter] $path(cat) > $path(test3)] chan puts $f "Line 1" chan puts $f "Line 2" chan close $f @@ -2628,7 +2631,7 @@ test chan-io-29.27 {Tcl_Flush on chan closed pipeline} -setup { chan puts $f {exit} chan close $f } -constraints {stdio openpipe} -body { - set f [open "|[list [interpreter] $path(pipe)]" r+] + set f [openpipe r+ $path(pipe)] chan gets $f chan puts $f output after 50 @@ -2698,7 +2701,7 @@ test chan-io-29.31 {Tcl_WriteChars, background flush} -setup { } set f [open $path(output) w] chan close $f - set f [open "|[list [interpreter] $path(pipe)]" r+] + set f [openpipe r+ $path(pipe)] chan configure $f -blocking off chan puts -nonewline $f $x chan close $f @@ -2740,7 +2743,7 @@ test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} -setup { } set f [open $path(output) w] chan close $f - set f [open "|[list [interpreter] $path(pipe)]" r+] + set f [openpipe r+ $path(pipe)] chan configure $f -blocking off chan puts -nonewline $f $x chan close $f @@ -3998,7 +4001,7 @@ test chan-io-32.10 {Tcl_Read from a pipe} -setup { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello chan flush $f1 chan read $f1 @@ -4013,7 +4016,7 @@ test chan-io-32.11 {Tcl_Read from a pipe} -setup { chan puts $f1 {chan puts [chan gets stdin]} chan puts $f1 {chan puts [chan gets stdin]} chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello chan flush $f1 lappend x [chan read $f1 6] @@ -4124,7 +4127,7 @@ test chan-io-33.3 {Tcl_Gets from pipe} -setup { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello chan flush $f1 chan gets $f1 @@ -4321,7 +4324,7 @@ test chan-io-34.7 {Tcl_Seek to offset from end of file, then to current position chan close $f1 } -result {44 rstuv 49} test chan-io-34.8 {Tcl_Seek on pipes: not supported} -setup { - set pipe [open "|[list [interpreter]]" r+] + set pipe [openpipe] } -constraints {stdio openpipe} -body { chan seek $pipe 0 current } -returnCodes error -cleanup { @@ -4433,13 +4436,13 @@ test chan-io-34.15 {Tcl_Tell combined with seeking} -setup { chan close $f1 } -result {10 20} test chan-io-34.16 {Tcl_Tell on pipe: always -1} -constraints {stdio openpipe} -body { - set f1 [open "|[list [interpreter]]" r+] + set f1 [openpipe] chan tell $f1 } -cleanup { chan close $f1 } -result -1 test chan-io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} { - set f1 [open "|[list [interpreter]]" r+] + set f1 [openpipe] chan puts $f1 {chan puts hello} chan flush $f1 set c [chan tell $f1] @@ -4547,7 +4550,7 @@ test chan-io-35.2 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup { chan puts $f1 {chan gets stdin} chan puts $f1 {chan puts hello} chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello set x [chan eof $f1] chan flush $f1 @@ -4566,7 +4569,7 @@ test chan-io-35.3 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup { chan puts $f1 {chan gets stdin} chan puts $f1 {chan puts hello} chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello set x [chan eof $f1] chan flush $f1 @@ -4603,7 +4606,7 @@ test chan-io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} -setup { exit } chan close $f - set f [open "|[list [interpreter] $path(pipe)]" r] + set f [openpipe r $path(pipe)] lappend l [chan gets $f] lappend l [chan eof $f] } -cleanup { @@ -4783,7 +4786,7 @@ test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} -setup { test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} -setup { set x "" } -constraints {stdio openpipe} -body { - set f1 [open "|[list [interpreter]]" r+] + set f1 [openpipe] chan puts $f1 {chan puts hello_from_pipe} chan flush $f1 chan gets $f1 @@ -4803,7 +4806,7 @@ test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} -setup { test chan-io-36.2 {Tcl_InputBlocked on blocking pipe} -setup { set x "" } -constraints {stdio openpipe} -body { - set f1 [open "|[list [interpreter]]" r+] + set f1 [openpipe] chan configure $f1 -buffering line chan puts $f1 {chan puts hello_from_pipe} lappend x [chan gets $f1] @@ -4837,17 +4840,14 @@ test chan-io-36.4 {Tcl_InputBlocked vs files, event driven read} -setup { set l "" variable x } -constraints {fileevent} -body { - proc in {f} { - variable l - variable x - lappend l [chan read $f 3] - if {[chan eof $f]} {lappend l eof; chan close $f; set x done} - } set f [open $path(test1) w] chan puts $f abcdefghijklmnop chan close $f set f [open $path(test1) r] - chan event $f readable [namespace code [list in $f]] + chan event $f readable [namespace code { + lappend l [chan read $f 3] + if {[chan eof $f]} {lappend l eof; chan close $f; set x done} + }] vwait [namespace which -variable x] return $l } -result {abc def ghi jkl mno {p @@ -4875,18 +4875,15 @@ test chan-io-36.6 {Tcl_InputBlocked vs files, event driven read} -setup { set l "" variable x } -constraints {nonBlockFiles fileevent} -body { - proc in {f} { - variable l - variable x - lappend l [chan read $f 3] - if {[chan eof $f]} {lappend l eof; chan close $f; set x done} - } set f [open $path(test1) w] chan puts $f abcdefghijklmnop chan close $f set f [open $path(test1) r] chan configure $f -blocking off - chan event $f readable [namespace code [list in $f]] + chan event $f readable [namespace code { + lappend l [chan read $f 3] + if {[chan eof $f]} {lappend l eof; chan close $f; set x done} + }] vwait [namespace which -variable x] return $l } -result {abc def ghi jkl mno {p @@ -5091,7 +5088,7 @@ test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} -setup { chan gets stdin } chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan configure $f1 -blocking off -buffering line lappend x [chan configure $f1 -blocking] lappend x [chan gets $f1] @@ -5180,7 +5177,7 @@ test chan-io-39.16 {Tcl_SetChannelOption: -encoding, errors} -setup { test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} -setup { variable x {} } -constraints {stdio openpipe fileevent} -body { - set f [open "|[list [interpreter] $path(cat)]" r+] + set f [openpipe r+ $path(cat)] chan configure $f -encoding binary chan puts -nonewline $f "\xe7" chan flush $f @@ -5630,7 +5627,7 @@ test chan-io-44.4 {FileEventProc procedure: eror in write event} -setup { catch {chan close $f3} } -result {bad-write {}} test chan-io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fileevent} { - set f4 [open "|[list [interpreter] $path(cat) << foo]" r] + set f4 [openpipe r $path(cat) << foo] chan event $f4 readable [namespace code { if {[chan gets $f4 line] < 0} { lappend x eof @@ -5657,7 +5654,9 @@ test chan-io-45.1 {DeleteFileEvent, cleanup on chan close} {fileevent} { }] chan close $f set x initial - after 100 [namespace code { set y done }] + after 100 [namespace code { + set y done + }] variable y vwait [namespace which -variable y] set x @@ -5666,9 +5665,9 @@ test chan-io-45.2 {DeleteFileEvent, cleanup on chan close} {fileevent} { set f [open $path(foo) r] set f2 [open $path(foo) r] chan event $f readable [namespace code { - lappend x "f triggered: \"[chan gets $f]\"" - chan event $f readable {} - }] + lappend x "f triggered: \"[chan gets $f]\"" + chan event $f readable {} + }] chan event $f2 readable [namespace code { lappend x "f2 triggered: \"[chan gets $f2]\"" chan event $f2 readable {} @@ -5860,10 +5859,7 @@ test chan-io-48.1 {testing readability conditions} {fileevent} { chan puts $f abcdefg chan close $f set f [open $path(bar) r] - chan event $f readable [namespace code [list consume $f]] - proc consume {f} { - variable l - variable x + chan event $f readable [namespace code { lappend l called if {[chan eof $f]} { chan close $f @@ -5871,7 +5867,7 @@ test chan-io-48.1 {testing readability conditions} {fileevent} { } else { chan gets $f } - } + }] set l "" variable x not_done vwait [namespace which -variable x] @@ -5886,11 +5882,7 @@ test chan-io-48.2 {testing readability conditions} {nonBlockFiles fileevent} { chan puts $f abcdefg chan close $f set f [open $path(bar) r] - chan event $f readable [namespace code [list consume $f]] - chan configure $f -blocking off - proc consume {f} { - variable x - variable l + chan event $f readable [namespace code { lappend l called if {[chan eof $f]} { chan close $f @@ -5898,7 +5890,8 @@ test chan-io-48.2 {testing readability conditions} {nonBlockFiles fileevent} { } else { chan gets $f } - } + }] + chan configure $f -blocking off set l "" variable x not_done vwait [namespace which -variable x] @@ -5926,13 +5919,8 @@ test chan-io-48.3 {testing readability conditions} -setup { } } chan close $f - set f [open "|[list [interpreter]]" r+] - chan event $f readable [namespace code [list consume $f]] - chan configure $f -buffering line - chan configure $f -blocking off - proc consume {f} { - variable l - variable x + set f [openpipe] + chan event $f readable [namespace code { if {[chan eof $f]} { set x done } else { @@ -5941,7 +5929,9 @@ test chan-io-48.3 {testing readability conditions} -setup { chan gets $f lappend l [chan blocked $f] } - } + }] + chan configure $f -buffering line + chan configure $f -blocking off variable x not_done chan puts $f [list source $path(my_script)] chan puts $f "set f \[[list open $path(bar) r]]" @@ -5961,10 +5951,9 @@ test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode chan configure $f -translation lf chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f - proc consume {f} { - variable l - variable c - variable x + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -5972,10 +5961,7 @@ test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode lappend l [chan gets $f] incr c } - } - set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l @@ -5989,10 +5975,9 @@ test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} chan configure $f -translation lf chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f - proc consume {f} { - variable l - variable x - variable c + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6000,10 +5985,7 @@ test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} lappend l [chan gets $f] incr c } - } - set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l @@ -6017,10 +5999,9 @@ test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode chan configure $f -translation cr chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f - proc consume {f} { - variable l - variable x - variable c + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6028,10 +6009,7 @@ test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode lappend l [chan gets $f] incr c } - } - set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l @@ -6045,10 +6023,9 @@ test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} chan configure $f -translation cr chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f - proc consume {f} { - variable l - variable c - variable x + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6056,10 +6033,7 @@ test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} lappend l [chan gets $f] incr c } - } - set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l @@ -6073,10 +6047,9 @@ test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mo chan configure $f -translation crlf chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f - proc consume {f} { - variable l - variable x - variable c + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6084,10 +6057,7 @@ test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mo lappend l [chan gets $f] incr c } - } - set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l @@ -6101,10 +6071,9 @@ test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode chan configure $f -translation crlf chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f - proc consume {f} { - variable l - variable c - variable x + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6112,10 +6081,7 @@ test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode lappend l [chan gets $f] incr c } - } - set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l @@ -6129,10 +6095,9 @@ test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} - chan configure $f -translation lf chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f - proc consume {f} { - variable l - variable c - variable x + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation lf + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6140,10 +6105,7 @@ test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} - lappend l [chan gets $f] incr c } - } - set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation lf - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l @@ -6157,10 +6119,9 @@ test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode} chan configure $f -translation lf chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f - proc consume {f} { - variable l - variable x - variable c + set f [open $path(test1) r] + chan configure $f -translation lf -eofchar \x1a + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6168,10 +6129,7 @@ test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode} lappend l [chan gets $f] incr c } - } - set f [open $path(test1) r] - chan configure $f -translation lf -eofchar \x1a - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l @@ -6185,10 +6143,9 @@ test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} - chan configure $f -translation cr chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f - proc consume {f} { - variable l - variable x - variable c + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation cr + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6196,10 +6153,7 @@ test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} - lappend l [chan gets $f] incr c } - } - set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation cr - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l @@ -6213,10 +6167,9 @@ test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode} chan configure $f -translation cr chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f - proc consume {f} { - variable c - variable x - variable l + set f [open $path(test1) r] + chan configure $f -translation cr -eofchar \x1a + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6224,10 +6177,7 @@ test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode} lappend l [chan gets $f] incr c } - } - set f [open $path(test1) r] - chan configure $f -translation cr -eofchar \x1a - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l @@ -6241,10 +6191,9 @@ test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mod chan configure $f -translation crlf chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f - proc consume {f} { - variable c - variable x - variable l + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation crlf + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6252,10 +6201,7 @@ test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mod lappend l [chan gets $f] incr c } - } - set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation crlf - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l @@ -6269,10 +6215,9 @@ test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} - chan configure $f -translation crlf chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f - proc consume {f} { - variable c - variable x - variable l + set f [open $path(test1) r] + chan configure $f -translation crlf -eofchar \x1a + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6280,10 +6225,7 @@ test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} - lappend l [chan gets $f] incr c } - } - set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar \x1a - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l @@ -6413,13 +6355,11 @@ test chan-io-50.1 {testing handler deletion} -setup { set f [open $path(test1) w] chan close $f set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delhandler $f]] - proc delhandler {f} { - variable z - set z called + testchannelevent $f add readable [namespace code { + variable z called testchannelevent $f delete 0 - } - set z not_called + }] + variable z not_called update return $z } -cleanup { @@ -6427,8 +6367,8 @@ test chan-io-50.1 {testing handler deletion} -setup { } -result called test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) - set f [open $path(test1) w] - chan close $f + chan close [open $path(test1) w] + set z "" } -constraints {testchannelevent} -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list delhandler $f 1]] @@ -6438,7 +6378,6 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { lappend z "called delhandler $f $i" testchannelevent $f delete 0 } - set z "" update string equal $z \ [list [list called delhandler $f 0] [list called delhandler $f 1]] @@ -6447,13 +6386,12 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { } -result 1 test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) - set f [open $path(test1) w] - chan close $f + chan close [open $path(test1) w] + set z "" } -constraints {testchannelevent} -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code [list notcalled $f 1]] testchannelevent $f add readable [namespace code [list delhandler $f 0]] - set z "" proc notcalled {f i} { variable z lappend z "notcalled was called!! $f $i" @@ -6465,7 +6403,6 @@ test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { testchannelevent $f delete 0 lappend z "delhandler $f $i deleted myself" } - set z "" update string equal $z \ [list [list delhandler $f 0 called] \ @@ -6479,11 +6416,8 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { chan close $f } -constraints {testchannelevent} -body { set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delrecursive $f]] - proc delrecursive {f} { - variable z - variable u - if {"$u" eq "recursive"} { + testchannelevent $f add readable [namespace code { + if {$u eq "recursive"} { testchannelevent $f delete 0 lappend z "delrecursive deleting recursive" } else { @@ -6491,7 +6425,7 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { set u recursive update } - } + }] variable u toplevel variable z "" update @@ -6514,7 +6448,7 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { proc del {f} { variable u variable z - if {"$u" eq "recursive"} { + if {$u eq "recursive"} { testchannelevent $f delete 1 testchannelevent $f delete 0 lappend z "del deleted notcalled" @@ -6545,7 +6479,7 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { proc first {f} { variable u variable z - if {"$u" == "toplevel"} { + if {$u eq "toplevel"} { lappend z "first called" set u first update @@ -6557,11 +6491,11 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { proc second {f} { variable u variable z - if {"$u" == "first"} { + if {$u eq "first"} { lappend z "second called, first time" set u second testchannelevent $f delete 0 - } elseif {"$u" == "second"} { + } elseif {$u eq "second"} { lappend z "second called, second time" testchannelevent $f delete 0 } else { @@ -6586,11 +6520,10 @@ test chan-io-51.1 {Test old socket deletion on Macintosh} -setup { } -constraints {socket} -body { proc accept {s a p} { variable x - variable wait chan configure $s -blocking off chan puts $s "sock[incr x]" chan close $s - set wait done + variable wait done } set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0] set port [lindex [chan configure $ss -sockname] 2] @@ -6598,17 +6531,14 @@ test chan-io-51.1 {Test old socket deletion on Macintosh} -setup { vwait [namespace which -variable wait] lappend result [chan gets $cs] chan close $cs - set wait "" set cs [socket 127.0.0.1 $port] vwait [namespace which -variable wait] lappend result [chan gets $cs] chan close $cs - set wait "" set cs [socket 127.0.0.1 $port] vwait [namespace which -variable wait] lappend result [chan gets $cs] chan close $cs - set wait "" set cs [socket 127.0.0.1 $port] vwait [namespace which -variable wait] lappend result [chan gets $cs] @@ -6770,7 +6700,7 @@ test chan-io-52.8 {TclCopyChannel} -setup { chan close \$f1 " chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan configure $f1 -translation lf chan gets $f1 chan puts $f1 ready @@ -6866,7 +6796,7 @@ test chan-io-53.2 {CopyData} -setup { chan close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {("$s1" == "$s2") && ($s0 == $s1)} { + if {($s1 == $s2) && ($s0 == $s1)} { lappend result ok } return $result @@ -6889,7 +6819,7 @@ test chan-io-53.3 {CopyData: background read underflow} -setup { chan close $f } chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] set result [chan gets $f1] chan puts $f1 line1 chan flush $f1 @@ -6924,7 +6854,7 @@ test chan-io-53.4 {CopyData: background write overflow} -setup { chan close $f } chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] set result [chan gets $f1] chan configure $f1 -blocking 0 chan puts $f1 $big @@ -6980,7 +6910,7 @@ test chan-io-53.6 {CopyData: error during chan copy} -setup { set f1 [open $path(pipe) w] chan puts $f1 "exit 1" chan close $f1 - set in [open "|[list [interpreter] $path(pipe)]" r+] + set in [openpipe r+ $path(pipe)] set out [open $path(test1) w] chan copy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone @@ -7029,7 +6959,7 @@ test chan-io-53.7 {CopyData: Flooding chan copy from pipe} -setup { exit 0 } chan close $f1 - set in [open "|[list [interpreter] $path(pipe) &]" r+] + set in [openpipe r+ $path(pipe) &] set out [open $path(test1) w] doFcopy $in $out variable fcopyTestDone @@ -7044,7 +6974,7 @@ test chan-io-53.7 {CopyData: Flooding chan copy from pipe} -setup { } -result {3450} test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -setup { # copy progress callback. errors out intentionally - proc ::cmd args { + proc cmd args { lappend ::RES "CMD $args" error !STOP } @@ -7064,7 +6994,7 @@ test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -se # Record input size, so that result is always defined lappend ::RES [file size $bar] # Run the copy. Should not invoke -command now. - chan copy $f $g -size 2 -command ::cmd + chan copy $f $g -size 2 -command [namespace code cmd] # Check that -command was not called synchronously set sbs [file size $bar] lappend ::RES [expr {($sbs > 0) ? "sync/FAIL" : "sync/OK"}] $sbs @@ -7077,20 +7007,19 @@ test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -se vwait ::forever catch {after cancel $token} # Report - set ::RES + return $::RES } -cleanup { chan close $f chan close $g catch {unset ::RES} catch {unset ::forever} - rename ::cmd {} rename ::bgerror {} removeFile foo removeFile bar } -result {0 sync/OK 0 {CMD 2} {bgerror/OK !STOP}} test chan-io-53.8a {CopyData: async callback and error handling, Bug 1932639, at eof} -setup { - # copy progress callback. errors out intentionally - proc ::cmd args { + # copy progress callback. + proc cmd args { lappend ::RES "CMD $args" set ::forever has-been-reached return @@ -7106,7 +7035,7 @@ test chan-io-53.8a {CopyData: async callback and error handling, Bug 1932639, at chan seek $f 0 end ; chan read $f 1 set ::RES [chan eof $f] # Run the copy. Should not invoke -command now. - chan copy $f $g -size 2 -command ::cmd + chan copy $f $g -size 2 -command [namespace code cmd] # Check that -command was not called synchronously lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}] # Now let the async part happen. Should capture the eof in cmd @@ -7118,13 +7047,12 @@ test chan-io-53.8a {CopyData: async callback and error handling, Bug 1932639, at vwait ::forever catch {after cancel $token} # Report - set ::RES + return $::RES } -cleanup { chan close $f chan close $g catch {unset ::RES} catch {unset ::forever} - rename ::cmd {} removeFile foo removeFile bar } -result {1 sync/OK {CMD 0}} @@ -7202,7 +7130,7 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { global l srv chan configure $sok -translation binary -buffering none lappend l $sok - if {[llength $l]==2} { + if {[llength $l] == 2} { chan close $srv foreach {a b} $l break chan copy $a $b -command [list geof $a] @@ -7222,7 +7150,7 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { # wait for OK from server. chan gets $pipe # Now the two clients. - proc ::done {sock} { + proc done {sock} { if {[chan eof $sock]} { chan close $sock ; return } lappend ::forever [chan gets $sock] return @@ -7231,8 +7159,8 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { set b [socket 127.0.0.1 9999] chan configure $a -translation binary -buffering none chan configure $b -translation binary -buffering none - chan event $a readable [list ::done $a] - chan event $b readable [list ::done $b] + chan event $a readable [namespace code "done $a"] + chan event $b readable [namespace code "done $b"] } -constraints {stdio openpipe fcopy} -body { # Now pass data through the server in both directions. set ::forever {} @@ -7245,7 +7173,6 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { catch {chan close $a} catch {chan close $b} chan close $pipe - rename ::done {} if {[testConstraint win]} { after 1000 ;# Give Windows time to kill the process } @@ -7309,6 +7236,7 @@ test chan-io-54.1 {Recursive channel events} {socket fileevent} { test chan-io-54.2 {Testing for busy-wait in recursive channel events} -setup { set accept {} set after {} + variable done 0 } -constraints {socket fileevent} -body { variable s [socket -server [namespace code accept] -myaddr 127.0.0.1 0] proc accept {s a p} { @@ -7321,17 +7249,20 @@ test chan-io-54.2 {Testing for busy-wait in recursive channel events} -setup { variable counter variable after incr counter - set l [chan gets $s] - if {"$l" == ""} { + if {[chan gets $s] eq ""} { chan event $s readable [namespace code "doit1 $s"] - set after [after 1000 [namespace code newline]] + set after [after 1000 [namespace code { + chan puts $writer hello + chan flush $writer + set done 1 + }]] } } proc doit1 {s} { variable counter variable accept incr counter - set l [chan gets $s] + chan gets $s chan close $s set accept {} } @@ -7343,15 +7274,7 @@ test chan-io-54.2 {Testing for busy-wait in recursive channel events} -setup { chan puts -nonewline $writer hello chan flush $writer } - proc newline {} { - variable done - variable writer - chan puts $writer hello - chan flush $writer - set done 1 - } producer - variable done vwait [namespace which -variable done] chan close $writer chan close $s @@ -7479,7 +7402,7 @@ test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc ope } } chan close $out - set pipe [open "|[list [interpreter] $path(script)]" r] + set pipe [openpipe r $path(script)] chan event $pipe readable [namespace code [list readit $pipe]] variable x "" set result "" @@ -7518,7 +7441,7 @@ test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent} { } } chan close $out - set pipe [open "|[list [interpreter] $path(script)]" r] + set pipe [openpipe r $path(script)] chan event $pipe readable [namespace code [list readit $pipe]] variable x "" set result "" diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 8932874..c4fd71d 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: ioTrans.test,v 1.9 2010/08/04 16:49:02 andreas_kupries Exp $ +# RCS: @(#) $Id: ioTrans.test,v 1.10 2010/11/24 11:56:57 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -19,8 +19,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } # Custom constraints used in this file -testConstraint testchannel [llength [info commands testchannel]] -testConstraint testthread [llength [info commands testthread]] +testConstraint testchannel [llength [info commands testchannel]] +testConstraint testthread [llength [info commands testthread]] # testchannel cut|splice Both needed to test the reflection in threads. # testthread send @@ -30,9 +30,9 @@ testConstraint testthread [llength [info commands testthread]] # ### ### ### ######### ######### ######### ## 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. +# 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} { @@ -40,69 +40,61 @@ set helperscript { namespace import -force ::tcltest::* } - proc note {item} {global res; lappend res $item; return} - #proc note {item} {global res; lappend res $item; puts $item ; flush stdout ; return} - proc track {} {upvar args item; note $item; return} - proc notes {items} {foreach i $items {note $i}} - - # Use to prevent *'s in pattern to match beyond the expected end - # of the recording. - proc endnote {} {note |} - - # This forces the return options to be in the order that the test - # expects! - proc noteOpts opts {global res; lappend res [dict merge { + # This forces the return options to be in the order that the test expects! + variable optorder { -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?! - } $opts]; return} + -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. + # optional methods as arguments. Use return features to post the result + # higher up. - proc init {args} { - lappend args initialize finalize read write - return -code return $args - } - proc oninit {args} { + proc handle.initialize {args} { upvar args hargs - if {[lindex $hargs 0] ne "initialize"} {return} - lappend args initialize finalize read write - return -code return $args + if {[lindex $hargs 0] eq "initialize"} { + return -code return [list {*}$args initialize finalize read write] + } } - proc onfinal {} { + proc handle.finalize {} { upvar args hargs - if {[lindex $hargs 0] ne "finalize"} {return} - return -code return "" + if {[lindex $hargs 0] eq "finalize"} { + return -code return "" + } } - proc onread {} { + proc handle.read {} { upvar args hargs - if {[lindex $hargs 0] ne "read"} {return} - return -code return "@" + if {[lindex $hargs 0] eq "read"} { + return -code return "@" + } } - proc ondrain {} { + proc handle.drain {} { upvar args hargs - if {[lindex $hargs 0] ne "drain"} {return} - return -code return "<>" + if {[lindex $hargs 0] eq "drain"} { + return -code return "<>" + } } - proc onclear {} { + proc handle.clear {} { upvar args hargs - if {[lindex $hargs 0] ne "clear"} {return} - return -code return "" + if {[lindex $hargs 0] eq "clear"} { + return -code return "" + } } proc tempchan {{mode r+}} { - global tempchan - set tempchan [open [makeFile {test data} tempchanfile] $mode] - return $tempchan + 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 } } @@ -110,379 +102,446 @@ set helperscript { eval $helperscript #puts <<[file channels]>> - + # ### ### ### ######### ######### ######### -test iortrans-1.0 {chan, wrong#args} { - catch {chan} msg - set msg -} {wrong # args: should be "chan subcommand ?arg ...?"} -test iortrans-1.1 {chan, unknown method} -body { +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 -} -returnCodes error -match glob -result {unknown or ambiguous subcommand "foo": must be*} +} -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} { - catch {chan push} msg - set msg -} {wrong # args: should be "chan push channel cmdprefix"} -test iortrans-2.1 {chan push, wrong#args, too many} { - catch {chan push a b c} msg - set msg -} {wrong # args: should be "chan push channel cmdprefix"} -test iortrans-2.2 {chan push, invalid channel} { +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 {} {} - catch {chan push {} foo} msg +} -returnCodes error -body { + chan push {} foo +} -cleanup { rename foo {} - set msg -} {can not find channel named ""} -test iortrans-2.3 {chan push, bad handler, not a list} { - catch {chan push [tempchan] "foo \{"} msg +} -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 - set msg -} {unmatched open brace in list} -test iortrans-2.4 {chan push, bad handler, not a command} { - catch {chan push [tempchan] foo} msg +} -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 - set msg -} {invalid command name "foo"} -test iortrans-2.5 {chan push, initialize failed, bad signature} { +} -result {invalid command name "foo"} +test iortrans-2.5 {chan push, initialize failed, bad signature} -body { proc foo {} {} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg -} {wrong # args: should be "foo"} -test iortrans-2.6 {chan push, initialize failed, bad signature} { +} -result {wrong # args: should be "foo"} +test iortrans-2.6 {chan push, initialize failed, bad signature} -body { proc foo {} {} - catch {chan push [tempchan] ::foo} msg + chan push [tempchan] ::foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg -} {wrong # args: should be "::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} msg + catch {chan push [tempchan] foo} + return $::errorInfo +} -cleanup { tempdone rename foo {} - set ::errorInfo } -match glob -result {chan handler "foo initialize" returned non-list: *} test iortrans-2.8 {chan push, initialize failed, bad result, not a list} -body { proc foo {args} {return \{\{\}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {chan handler "foo initialize" returned non-list: *} test iortrans-2.9 {chan push, initialize failed, bad result, empty list} -body { proc foo {args} {} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*all required methods*} test iortrans-2.10 {chan push, initialize failed, bad result, bogus method name} -body { proc foo {args} {return 1} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*bad method "1": must be *} test iortrans-2.11 {chan push, initialize failed, bad result, bogus method name} -body { proc foo {args} {return {a b c}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*bad method "c": must be *} test iortrans-2.12 {chan push, initialize failed, bad result, required methods missing} -body { # Required: initialize, and finalize. proc foo {args} {return {initialize}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*all required methods*} test iortrans-2.13 {chan push, initialize failed, bad result, illegal method name} -body { proc foo {args} {return {initialize finalize BOGUS}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*returned bad method "BOGUS": must be clear, drain, finalize, flush, initialize, limit?, read, or write} test iortrans-2.14 {chan push, initialize failed, bad result, mode/handler mismatch} -body { proc foo {args} {return {initialize finalize}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*makes the channel inacessible} # iortrans-2.15 event/watch methods elimimated, removed these tests. # iortrans-2.16 test iortrans-2.17 {chan push, initialize failed, bad result, drain/read mismatch} -body { proc foo {args} {return {initialize finalize drain write}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*supports "drain" but not "read"} test iortrans-2.18 {chan push, initialize failed, bad result, flush/write mismatch} -body { proc foo {args} {return {initialize finalize flush read}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*supports "flush" but not "write"} -test iortrans-2.19 {chan push, initialize ok, creates channel} -match glob -body { +test iortrans-2.19 {chan push, initialize ok, creates channel} -setup { + set res {} +} -match glob -body { proc foo {args} { - global res + global res lappend res $args if {[lindex $args 0] ne "initialize"} {return} return {initialize finalize drain flush read write} } - set res {} lappend res [file channel rt*] lappend res [chan push [tempchan] foo] lappend res [close [lindex $res end]] lappend res [file channel rt*] +} -cleanup { tempdone rename foo {} - set res } -result {{} {initialize rt* {read write}} file* {drain rt*} {flush rt*} {finalize rt*} {} {}} -test iortrans-2.20 {chan push, init failure -> no channel, no finalize} -match glob -body { +test iortrans-2.20 {chan push, init failure -> no channel, no finalize} -setup { + set res {} +} -match glob -body { proc foo {args} { - global res + global res lappend res $args - return {} + return } - set res {} lappend res [file channel rt*] - lappend res [catch {chan push [tempchan] foo} msg] - lappend res $msg + lappend res [catch {chan push [tempchan] foo} msg] $msg lappend res [file channel rt*] +} -cleanup { tempdone rename foo {} - set res } -result {{} {initialize rt* {read write}} 1 {*all required methods*} {}} # --- --- --- --------- --------- --------- # method finalize (via close) -# General note: file channels rt* finds the transform channel, however -# the name reported will be that of the underlying base driver, fileXX -# here. This actually allows us to see if the whole channel is gone, -# or only the transformation, but not the base. +# General note: file channels rt* finds the transform channel, however the +# name reported will be that of the underlying base driver, fileXX here. This +# actually allows us to see if the whole channel is gone, or only the +# transformation, but not the base. -test iortrans-3.1 {chan finalize, handler destruction has no effect on channel} -match glob -body { +test iortrans-3.1 {chan finalize, handler destruction has no effect on channel} -setup { set res {} - proc foo {args} {track; oninit; return} - note [set c [chan push [tempchan] foo]] +} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return + } + lappend res [set c [chan push [tempchan] foo]] rename foo {} - note [file channels file*] - note [file channels rt*] - note [catch {close $c} msg]; note $msg - note [file channels file*] - note [file channels rt*] - set res + 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} -match glob -body { +test iortrans-3.2 {chan finalize, for close} -setup { set res {} - proc foo {args} {track; oninit; return {}} - note [set c [chan push [tempchan] foo]] +} -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. - note [file channels rt*] + lappend res [file channels rt*] # Channel destruction does not kill handler command! - note [info command foo] + lappend res [info command foo] +} -cleanup { rename foo {} - set res } -result {{initialize rt* {read write}} file* {finalize rt*} {} foo} -test iortrans-3.3 {chan finalize, for close, error, close error} -match glob -body { +test iortrans-3.3 {chan finalize, for close, error, close error} -setup { set res {} - proc foo {args} {track; oninit; return -code error 5} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg]; note $msg +} -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. - note [file channels rt*] + lappend res [file channels rt*] +} -cleanup { rename foo {} - set res } -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}} -test iortrans-3.4 {chan finalize, for close, error, close error} -match glob -body { +test iortrans-3.4 {chan finalize, for close, error, close error} -setup { set res {} - proc foo {args} {track; oninit; error FOO} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg]; note $msg; note $::errorInfo +} -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 {} - set res } -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO {FOO *"close $c"}} -test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -match glob -body { +test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -setup { set res {} - proc foo {args} {track; oninit; return SOMETHING} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg]; note $msg +} -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 {} - set res } -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}} -test iortrans-3.6 {chan finalize, for close, break, close error} -match glob -body { +test iortrans-3.6 {chan finalize, for close, break, close error} -setup { set res {} - proc foo {args} {track; oninit; return -code 3} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg]; note $msg +} -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 {} - set res } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} -test iortrans-3.7 {chan finalize, for close, continue, close error} -match glob -body { +test iortrans-3.7 {chan finalize, for close, continue, close error} -setup { set res {} - proc foo {args} {track; oninit; return -code 4} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg]; note $msg +} -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 {} - set res } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} -test iortrans-3.8 {chan finalize, for close, custom code, close error} -match glob -body { +test iortrans-3.8 {chan finalize, for close, custom code, close error} -setup { set res {} - proc foo {args} {track; oninit; return -code 777 BANG} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg]; note $msg +} -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 {} - set res } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} -test iortrans-3.9 {chan finalize, for close, ignore level, close error} -match glob -setup { +test iortrans-3.9 {chan finalize, for close, ignore level, close error} -setup { set res {} } -body { - proc foo {args} {track; oninit; return -level 5 -code 777 BANG} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg opt]; note $msg; noteOpts $opt - return $res -} -cleanup { + 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} -match glob -body { +test iortrans-4.1 {chan read, transform call and return} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return snarf } set c [chan push [tempchan] foo] - note [read $c 10] + lappend res [read $c 10] +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} snarf} -test iortrans-4.2 {chan read, for non-readable channel} -match glob -body { +test iortrans-4.2 {chan read, for non-readable channel} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track; note MUST_NOT_HAPPEN + handle.initialize + handle.finalize + lappend ::res $args MUST_NOT_HAPPEN } set c [chan push [tempchan w] foo] - note [catch {read $c 2} msg]; note $msg + lappend res [catch {read $c 2} msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {1 {channel "file*" wasn't opened for reading}} -test iortrans-4.3 {chan read, error return} -match glob -body { +test iortrans-4.3 {chan read, error return} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code error BOOM! } set c [chan push [tempchan] foo] - note [catch {read $c 2} msg]; note $msg + lappend res [catch {read $c 2} msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} 1 BOOM!} -test iortrans-4.4 {chan read, break return is error} -match glob -body { +test iortrans-4.4 {chan read, break return is error} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code break BOOM! } set c [chan push [tempchan] foo] - note [catch {read $c 2} msg]; note $msg + lappend res [catch {read $c 2} msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} 1 *bad code*} -test iortrans-4.5 {chan read, continue return is error} -match glob -body { +test iortrans-4.5 {chan read, continue return is error} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code continue BOOM! } set c [chan push [tempchan] foo] - note [catch {read $c 2} msg]; note $msg + lappend res [catch {read $c 2} msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} 1 *bad code*} -test iortrans-4.6 {chan read, custom return is error} -match glob -body { +test iortrans-4.6 {chan read, custom return is error} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code 777 BOOM! } set c [chan push [tempchan] foo] - note [catch {read $c 2} msg]; note $msg + lappend res [catch {read $c 2} msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} 1 *bad code*} -test iortrans-4.7 {chan read, level is squashed} -match glob -body { +test iortrans-4.7 {chan read, level is squashed} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -level 55 -code 777 BOOM! } set c [chan push [tempchan] foo] - note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt + lappend res [catch {read $c 2} msg opt] $msg + noteOpts $opt +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} -test iortrans-4.8 {chan read, read, bug 2921116} -match glob -setup { +test iortrans-4.8 {chan read, read, bug 2921116} -setup { set res {} +} -match glob -body { proc foo {fd args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args # Kill and recreate transform while it is operating - chan pop $fd + chan pop $fd chan push $fd [list foo $fd] } set c [chan push [set c [tempchan]] [list foo $c]] -} -body { - note [read $c] - #note [gets $c] - set res + 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} -match glob -setup { +test iortrans-4.9 {chan read, gets, bug 2921116} -setup { set res {} +} -match glob -body { proc foo {fd args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args # Kill and recreate transform while it is operating - chan pop $fd + chan pop $fd chan push $fd [list foo $fd] } set c [chan push [set c [tempchan]] [list foo $c]] -} -body { - note [gets $c] - set res + lappend res [gets $c] } -cleanup { tempdone rename foo {} @@ -492,127 +551,207 @@ test iortrans-4.9 {chan read, gets, bug 2921116} -match glob -setup { # --- === *** ########################### # method write (via puts) -test iortrans-5.1 {chan write, regular write} -match glob -body { +test iortrans-5.1 {chan write, regular write} -setup { set res {} - proc foo {args} { oninit; onfinal; track ; return transformresult } +} -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 + puts -nonewline $c snarf + flush $c close $c - note [tempview] + lappend res [tempview] +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarf} transformresult} -test iortrans-5.2 {chan write, no write is ok, no change to file} -match glob -body { +test iortrans-5.2 {chan write, no write is ok, no change to file} -setup { set res {} - proc foo {args} { oninit; onfinal; track ; return {} } +} -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 + puts -nonewline $c snarfsnarfsnarf + flush $c close $c - note [tempview];# This has to show the original data, as nothing was written + lappend res [tempview]; # This has to show the original data, as nothing was written +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} {test data}} -test iortrans-5.3 {chan write, failed write} -match glob -body { +test iortrans-5.3 {chan write, failed write} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code error FAIL!} +} -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 - note [catch {flush $c} msg] ; note $msg + lappend res [catch {flush $c} msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} 1 FAIL!} -test iortrans-5.4 {chan write, non-writable channel} -match glob -body { +test iortrans-5.4 {chan write, non-writable channel} -setup { set res {} - proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args MUST_NOT_HAPPEN + return + } set c [chan push [tempchan r] foo] - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]; note $msg + lappend res [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg +} -cleanup { close $c tempdone rename foo {} - set res } -result {1 {channel "file*" wasn't opened for writing}} -test iortrans-5.5 {chan write, failed write, error return} -match glob -body { +test iortrans-5.5 {chan write, failed write, error return} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code error BOOM!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code error BOOM! + } set c [chan push [tempchan] foo] - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} 1 BOOM!} -test iortrans-5.6 {chan write, failed write, error return} -match glob -body { +test iortrans-5.6 {chan write, failed write, error return} -setup { set res {} - proc foo {args} {oninit; onfinal; track; error BOOM!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + error BOOM! + } set c [chan push [tempchan] foo] - notes [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} 1 BOOM!} -test iortrans-5.7 {chan write, failed write, break return is error} -match glob -body { +test iortrans-5.7 {chan write, failed write, break return is error} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code break BOOM!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code break BOOM! + } set c [chan push [tempchan] foo] - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} 1 *bad code*} -test iortrans-5.8 {chan write, failed write, continue return is error} -match glob -body { +test iortrans-5.8 {chan write, failed write, continue return is error} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code continue BOOM!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code continue BOOM! + } set c [chan push [tempchan] foo] - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} 1 *bad code*} -test iortrans-5.9 {chan write, failed write, custom return is error} -match glob -body { +test iortrans-5.9 {chan write, failed write, custom return is error} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code 777 BOOM! + } set c [chan push [tempchan] foo] - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} 1 *bad code*} -test iortrans-5.10 {chan write, failed write, level is ignored} -match glob -body { +test iortrans-5.10 {chan write, failed write, level is ignored} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!} +} -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] - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt] - note $msg + lappend res [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg opt] $msg noteOpts $opt +} -cleanup { tempdone rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} +} -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} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args # pop - invokes flush - invokes 'foo write' - infinite recursion - stop it global level - if {$level} { return "" } + if {$level} { + return + } incr level # Kill and recreate transform while it is operating - chan pop $fd + chan pop $fd chan push $fd [list foo $fd] } set c [chan push [set c [tempchan]] [list foo $c]] -} -body { - note [puts -nonewline $c abcdef] - note [flush $c] - set res + lappend res [puts -nonewline $c abcdef] + lappend res [flush $c] } -cleanup { tempdone rename foo {} @@ -621,85 +760,110 @@ test iortrans-5.11 {chan write, bug 2921116} -match glob -setup { # --- === *** ########################### # method limit?, drain (via read) -test iortrans-6.1 {chan read, read limits} -match glob -body { +test iortrans-6.1 {chan read, read limits} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit limit?; onfinal; track ; onread + handle.initialize limit? + handle.finalize + lappend ::res $args + handle.read return 6 } set c [chan push [tempchan] foo] - note [read $c 10] + lappend res [read $c 10] +} -cleanup { tempdone rename foo {} - set res } -result {{limit? rt*} {read rt* {test d}} {limit? rt*} {read rt* {ata }} {limit? rt*} @@} -test iortrans-6.2 {chan read, read transform drain on eof} -match glob -body { +test iortrans-6.2 {chan read, read transform drain on eof} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit drain; onfinal; track ; onread ; ondrain + handle.initialize drain + handle.finalize + lappend ::res $args + handle.read + handle.drain return } set c [chan push [tempchan] foo] - note [read $c] - note [close $c] + lappend res [read $c] + lappend res [close $c] +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} {drain rt*} @<> {}} # --- === *** ########################### # method clear (via puts, seek) -test iortrans-7.1 {chan write, write clears read buffers} -match glob -body { +test iortrans-7.1 {chan write, write clears read buffers} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit clear; onfinal; track ; onclear + handle.initialize clear + handle.finalize + lappend ::res $args + handle.clear return transformresult } set c [chan push [tempchan] foo] - puts -nonewline $c snarf; flush $c + puts -nonewline $c snarf + flush $c + return $res +} -cleanup { tempdone rename foo {} - set res } -result {{clear rt*} {write rt* snarf}} -test iortrans-7.2 {seek clears read buffers} -match glob -body { +test iortrans-7.2 {seek clears read buffers} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit clear; onfinal; track + handle.initialize clear + handle.finalize + lappend ::res $args return } set c [chan push [tempchan] foo] seek $c 2 + return $res +} -cleanup { tempdone rename foo {} - set res } -result {{clear rt*}} -test iortrans-7.3 {clear, any result is ignored} -match glob -body { +test iortrans-7.3 {clear, any result is ignored} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit clear; onfinal; track + 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 {} - set res } -result {{clear rt*}} test iortrans-7.4 {chan clear, bug 2921116} -match glob -setup { set res {} +} -body { proc foo {fd args} { - oninit clear; onfinal; track + handle.initialize clear + handle.finalize + lappend ::res $args # Kill and recreate transform while it is operating - chan pop $fd + chan pop $fd chan push $fd [list foo $fd] } set c [chan push [set c [tempchan]] [list foo $c]] -} -body { seek $c 2 - set res + return $res } -cleanup { tempdone rename foo {} @@ -708,47 +872,53 @@ test iortrans-7.4 {chan clear, bug 2921116} -match glob -setup { # --- === *** ########################### # method flush (via seek, close) -test iortrans-8.1 {seek flushes write buffers, ignores data} -match glob -body { +test iortrans-8.1 {seek flushes write buffers, ignores data} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit flush; onfinal; track + 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! - note | ; note [close $c] ; note | - note [tempview] + lappend res | + lappend res [close $c] | [tempview] +} -cleanup { tempdone rename foo {} - set res } -result {{flush rt*} | {flush rt*} {} | {teXt data}} - -test iortrans-8.2 {close flushes write buffers, writes data} -match glob -body { +test iortrans-8.2 {close flushes write buffers, writes data} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit flush; track ; onfinal + handle.initialize flush + lappend ::res $args + handle.finalize return .flushed. } set c [chan push [tempchan] foo] close $c - note [tempview] + lappend res [tempview] +} -cleanup { tempdone rename foo {} - set res } -result {{flush rt*} {finalize rt*} .flushed.} - test iortrans-8.3 {chan flush, bug 2921116} -match glob -setup { set res {} +} -body { proc foo {fd args} { - oninit flush; onfinal; track + handle.initialize flush + handle.finalize + lappend ::res $args # Kill and recreate transform while it is operating - chan pop $fd + chan pop $fd chan push $fd [list foo $fd] } set c [chan push [set c [tempchan]] [list foo $c]] -} -body { seek $c 2 set res } -cleanup { @@ -763,139 +933,128 @@ test iortrans-8.3 {chan flush, bug 2921116} -match glob -setup { # method event - removed from TIP (rev 1.12+) # --- === *** ########################### -# 'Pull the rug' tests. Create channel in a interpreter A, move to -# other interpreter B, destroy the origin interpreter (A) before or -# during access from B. Must not crash, must return proper errors. - -test iortrans-11.0 {origin interpreter of moved transform gone} -match glob -body { - - set ida [interp create];#puts <<$ida>> - set idb [interp create];#puts <<$idb>> - +# '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} {oninit clear drain flush limit? read write; onfinal; track; return} + 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 $ida [list testchannel cut $chan] interp eval $idb [list testchannel splice $chan] - # Kill origin interpreter, then access channel from 2nd interpreter. interp delete $ida - - set res {} - lappend res [catch {interp eval $idb [list puts $chan shoo]} msg] $msg - lappend res [catch {interp eval $idb [list tell $chan]} msg] $msg - lappend res [catch {interp eval $idb [list seek $chan 1]} msg] $msg - lappend res [catch {interp eval $idb [list gets $chan]} msg] $msg - lappend res [catch {interp eval $idb [list close $chan]} msg] $msg + 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 - set res - # The 'tell' is ok, as it passed through the transform to the base - # channel without invoking the transform handler. -} -constraints {testchannel} \ - -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} - -test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -match glob -body { - - set ida [interp create];#puts <<$ida>> - set idb [interp create];#puts <<$idb>> - +} -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} { - oninit clear drain flush limit? read write; onfinal; track; - # destroy interpreter during channel access - # Actually not possible for an interp to destroy itself. + 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 $ida [list testchannel cut $chan] interp eval $idb [list testchannel splice $chan] - - # Run access from interpreter B, this will give us a synchronous - # response. - + # Run access from interpreter B, this will give us a synchronous response. interp eval $idb [list set chan $chan] interp eval $idb [list set mid $tcltest::mainThread] set res [interp eval $idb { - # wait a bit, give the main thread the time to start its event - # loop to wait for the response from B - after 2000 + # 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 - set res -} -constraints {testchannel impossible} \ - -result {Owner lost} - - -test iortrans-11.2 {delete interp of reflected transform} -body { +} -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}} + 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 + chan event $c readable no-op } interp delete slave -} -result {} -constraints {testchannel} - +} -result {} + # ### ### ### ######### ######### ######### -## Same tests as above, but exercising the code forwarding and -## receiving driver operations to the originator thread. +## Same tests as above, but exercising the code forwarding and receiving +## driver operations to the originator thread. -# -*- tcl -*- # ### ### ### ######### ######### ######### ## Testing the reflected channel (Thread forwarding). # -## The id numbers refer to the original test without thread -## forwarding, and gaps due to tests not applicable to forwarding are -## left to keep this association. +## The id numbers refer to the original test without thread forwarding, and +## gaps due to tests not applicable to forwarding are left to keep this +## association. -# Duplicate of code in "thread.test", and "ioCmd.test". Find a better -# way of doing this without duplication. Maybe placement into a proc -# which transforms to nop after the first call, and placement of its -# defintion in a central location. +# Duplicate of code in "thread.test", and "ioCmd.test". Find a better way of +# doing this without duplication. Maybe placement into a proc which transforms +# to nop after the first call, and placement of its defintion in a central +# location. if {[testConstraint testthread]} { testthread errorproc ThreadError - proc ThreadError {id info} { global threadError set threadError $info @@ -906,13 +1065,12 @@ if {[testConstraint testthread]} { } # ### ### ### ######### ######### ######### -## 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 +## Helper command. Runs a script in a separate thread and returns the result. +## A channel is transfered into the thread as well, and a list of configuation +## variables proc inthread {chan script args} { # Test thread. - set tid [testthread create] # Init thread configuration. @@ -926,11 +1084,15 @@ proc inthread {chan script args} { } testthread send $tid [list set mid $tcltest::mainThread] testthread send $tid { - proc note {item} {global notes; lappend notes $item} - proc notes {} {global notes; return $notes} - proc noteOpts opts {global notes; lappend notes [dict merge { - -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?! - } $opts]} + proc notes {} { + return $::notes + } + proc noteOpts opts { + lappend ::notes [dict merge { + -code !?! -level !?! -errorcode !?! -errorline !?! + -errorinfo !?! -errorstack !?! + } $opts] + } } testthread send $tid [list proc s {} [list uplevel 1 $script]]; # (*) @@ -939,15 +1101,14 @@ proc inthread {chan script args} { testchannel cut $chan testthread send $tid [list testchannel splice $chan] - # Run test script, also run local event loop! - # The local event loop waits for the result to come back. - # It is also necessary for the execution of forwarded channel - # operations. + # Run test script, also run local event loop! The local event loop waits + # for the result to come back. It is also necessary for the execution of + # forwarded channel operations. set ::tres "" testthread send -async $tid { - after 500 - catch {s} res; # This runs the script, 's' was defined at (*) + after 50 + catch {s} res; # This runs the script, 's' was defined at (*) testthread send -async $mid [list set ::tres $res] } vwait ::tres @@ -959,454 +1120,579 @@ proc inthread {chan script args} { # ### ### ### ######### ######### ######### -# ### ### ### ######### ######### ######### - -test iortrans.tf-3.2 {chan finalize, for close} -match glob -body { +test iortrans.tf-3.2 {chan finalize, for close} -setup { set res {} - proc foo {args} {track; oninit; return {}} - note [set c [chan push [tempchan] foo]] - note [inthread $c { +} -constraints {testchannel testthread} -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! - note [info command foo] + lappend res [info command foo] +} -cleanup { rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {{initialize rt* {read write}} file* {finalize rt*} {} foo} -test iortrans.tf-3.3 {chan finalize, for close, error, close error} -match glob -body { - set res {} - proc foo {args} {track; oninit; return -code error 5} - note [set c [chan push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg]; note $msg +} -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 testthread} -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. - note [file channels rt*] + lappend notes [file channels rt*] notes } c] +} -cleanup { rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}} -test iortrans.tf-3.4 {chan finalize, for close, error, close errror} -match glob -body { - set res {} - proc foo {args} {track; oninit; error FOO} - note [set c [chan push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg]; note $msg +} -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 testthread} -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 {} - set res -} -constraints {testchannel testthread} \ - -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO} -test iortrans.tf-3.5 {chan finalize, for close, arbitrary result} -match glob -body { - set res {} - proc foo {args} {track; oninit; return SOMETHING} - note [set c [chan push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg]; note $msg +} -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 testthread} -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 {} - set res -} -constraints {testchannel testthread} \ - -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}} -test iortrans.tf-3.6 {chan finalize, for close, break, close error} -match glob -body { - set res {} - proc foo {args} {track; oninit; return -code 3} - note [set c [chan push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg]; note $msg +} -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 testthread} -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 {} - set res -} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \ - -constraints {testchannel testthread} - - -test iortrans.tf-3.7 {chan finalize, for close, continue, close error} -match glob -body { +} -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 {} - proc foo {args} {track; oninit; return -code 4} - note [set c [chan push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg]; note $msg +} -constraints {testchannel testthread} -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 {} - set res -} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-3.8 {chan finalize, for close, custom code, close error} -match glob -body { - set res {} - proc foo {args} {track; oninit; return -code 777 BANG} - note [set c [chan push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg]; note $msg +} -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 testthread} -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 {} - set res -} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-3.9 {chan finalize, for close, ignore level, close error} -match glob -body { - set res {} - proc foo {args} {track; oninit; return -level 5 -code 777 BANG} - note [set c [chan push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg opt]; note $msg; noteOpts $opt +} -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 testthread} -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 {} - set res -} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} \ - -constraints {testchannel testthread} +} -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} -match glob -body { +test iortrans.tf-4.1 {chan read, transform call and return} -setup { set res {} +} -constraints {testchannel testthread} -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return snarf } set c [chan push [tempchan] foo] - notes [inthread $c { - note [read $c 10] + lappend res {*}[inthread $c { + lappend notes [read $c 10] close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -constraints {testchannel testthread} -result {{read rt* {test data +} -match glob -result {{read rt* {test data }} snarf} - -test iortrans.tf-4.2 {chan read, for non-readable channel} -match glob -body { +test iortrans.tf-4.2 {chan read, for non-readable channel} -setup { set res {} +} -constraints {testchannel testthread} -body { proc foo {args} { - oninit; onfinal; track; note MUST_NOT_HAPPEN + handle.initialize + handle.finalize + lappend ::res $args MUST_NOT_HAPPEN } set c [chan push [tempchan w] foo] - notes [inthread $c { - note [catch {[read $c 2]} msg]; note $msg + lappend res {*}[inthread $c { + lappend notes [catch {[read $c 2]} msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -constraints {testchannel testthread} -result {1 {channel "file*" wasn't opened for reading}} -test iortrans.tf-4.3 {chan read, error return} -match glob -body { +} -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 testthread} -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code error BOOM! } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {read $c 2} msg]; note $msg + lappend res {*}[inthread $c { + lappend notes [catch {read $c 2} msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{read rt* {test data -}} 1 BOOM!} \ - -constraints {testchannel testthread} -test iortrans.tf-4.4 {chan read, break return is error} -match glob -body { +} -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 testthread} -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code break BOOM! } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {read $c 2} msg]; note $msg + lappend res {*}[inthread $c { + lappend notes [catch {read $c 2} msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{read rt* {test data -}} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-4.5 {chan read, continue return is error} -match glob -body { +} -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 testthread} -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code continue BOOM! } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {read $c 2} msg]; note $msg + lappend res {*}[inthread $c { + lappend notes [catch {read $c 2} msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{read rt* {test data -}} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-4.6 {chan read, custom return is error} -match glob -body { +} -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 testthread} -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code 777 BOOM! } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {read $c 2} msg]; note $msg + lappend res {*}[inthread $c { + lappend notes [catch {read $c 2} msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{read rt* {test data -}} 1 *bad code*} \ - -constraints {testchannel testthread} - -test iortrans.tf-4.7 {chan read, level is squashed} -match glob -body { +} -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 testthread} -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -level 55 -code 777 BOOM! } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt + lappend res {*}[inthread $c { + lappend notes [catch {read $c 2} msg opt] $msg + noteOpts $opt close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{read rt* {test data -}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} \ - -constraints {testchannel testthread} +} -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} -match glob -body { +test iortrans.tf-5.1 {chan write, regular write} -setup { set res {} - proc foo {args} { oninit; onfinal; track ; return transformresult } +} -constraints {testchannel testthread} -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 + puts -nonewline $c snarf + flush $c close $c } c - note [tempview] + lappend res [tempview] +} -cleanup { tempdone rename foo {} - set res -} -constraints {testchannel testthread} -result {{write rt* snarf} transformresult} -test iortrans.tf-5.2 {chan write, no write is ok, no change to file} -match glob -body { +} -result {{write rt* snarf} transformresult} +test iortrans.tf-5.2 {chan write, no write is ok, no change to file} -setup { set res {} - proc foo {args} { oninit; onfinal; track ; return {} } +} -constraints {testchannel testthread} -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 + puts -nonewline $c snarfsnarfsnarf + flush $c close $c } c - note [tempview];# This has to show the original data, as nothing was written + lappend res [tempview]; # This has to show the original data, as nothing was written +} -cleanup { tempdone rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {{write rt* snarfsnarfsnarf} {test data}} -test iortrans.tf-5.3 {chan write, failed write} -match glob -body { +} -result {{write rt* snarfsnarfsnarf} {test data}} +test iortrans.tf-5.3 {chan write, failed write} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code error FAIL!} +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code error FAIL! + } set c [chan push [tempchan] foo] - notes [inthread $c { + lappend res {*}[inthread $c { puts -nonewline $c snarfsnarfsnarf - note [catch {flush $c} msg] - note $msg + lappend notes [catch {flush $c} msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {{write rt* snarfsnarfsnarf} 1 FAIL!} -test iortrans.tf-5.4 {chan write, non-writable channel} -match glob -body { +} -result {{write rt* snarfsnarfsnarf} 1 FAIL!} +test iortrans.tf-5.4 {chan write, non-writable channel} -setup { set res {} - proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args MUST_NOT_HAPPEN + return + } set c [chan push [tempchan r] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {1 {channel "file*" wasn't opened for writing}} -test iortrans.tf-5.5 {chan write, failed write, error return} -match glob -body { +} -result {1 {channel "file*" wasn't opened for writing}} +test iortrans.tf-5.5 {chan write, failed write, error return} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code error BOOM!} +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code error BOOM! + } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} \ - -constraints {testchannel testthread} -test iortrans.tf-5.6 {chan write, failed write, error return} -match glob -body { +} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} +test iortrans.tf-5.6 {chan write, failed write, error return} -setup { set res {} - proc foo {args} {oninit; onfinal; track; error BOOM!} +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + error BOOM! + } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} \ - -constraints {testchannel testthread} - - -test iortrans.tf-5.7 {chan write, failed write, break return is error} -match glob -body { +} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} +test iortrans.tf-5.7 {chan write, failed write, break return is error} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code break BOOM!} +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code break BOOM! + } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-5.8 {chan write, failed write, continue return is error} -match glob -body { +} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} +test iortrans.tf-5.8 {chan write, failed write, continue return is error} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code continue BOOM!} +} -constraints {testchannel testthread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code continue BOOM! + } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg close $c notes } c] +} -cleanup { rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-5.9 {chan write, failed write, custom return is error} -match glob -body { +} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} +test iortrans.tf-5.9 {chan write, failed write, custom return is error} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!} +} -constraints {testchannel testthread} -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code 777 BOOM! + } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-5.10 {chan write, failed write, level is ignored} -match glob -body { +} -match glob -result {{write rt* snarfsnarfsnarf} 1 *bad code*} +test iortrans.tf-5.10 {chan write, failed write, level is ignored} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!} +} -constraints {testchannel testthread} -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] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt] - note $msg + 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 {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} \ - -constraints {testchannel testthread} - +} -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} -match glob -body { +test iortrans.tf-6.1 {chan read, read limits} -setup { set res {} +} -constraints {testchannel testthread} -match glob -body { proc foo {args} { - oninit limit?; onfinal; track ; onread + handle.initialize limit? + handle.finalize + lappend ::res $args + handle.read return 6 } set c [chan push [tempchan] foo] - notes [inthread $c { - note [read $c 10] + lappend res {*}[inthread $c { + lappend notes [read $c 10] close $c - set notes + notes } c] +} -cleanup { tempdone rename foo {} - set res } -result {{limit? rt*} {read rt* {test d}} {limit? rt*} {read rt* {ata -}} {limit? rt*} @@} -constraints {testchannel testthread} -test iortrans.tf-6.2 {chan read, read transform drain on eof} -match glob -body { +}} {limit? rt*} @@} +test iortrans.tf-6.2 {chan read, read transform drain on eof} -setup { set res {} +} -constraints {testchannel testthread} -match glob -body { proc foo {args} { - oninit drain; onfinal; track ; onread ; ondrain + handle.initialize drain + handle.finalize + lappend ::res $args + handle.read + handle.drain return } set c [chan push [tempchan] foo] - notes [inthread $c { - note [read $c] - note [close $c] + lappend res {*}[inthread $c { + lappend notes [read $c] + lappend notes [close $c] } c] +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data -}} {drain rt*} @<> {}} -constraints {testchannel testthread} +}} {drain rt*} @<> {}} # --- === *** ########################### # method clear (via puts, seek) -test iortrans.tf-7.1 {chan write, write clears read buffers} -match glob -body { +test iortrans.tf-7.1 {chan write, write clears read buffers} -setup { set res {} +} -constraints {testchannel testthread} -match glob -body { proc foo {args} { - oninit clear; onfinal; track ; onclear + 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 + puts -nonewline $c snarf + flush $c close $c } c + return $res +} -cleanup { tempdone rename foo {} - set res -} -result {{clear rt*} {write rt* snarf}} -constraints {testchannel testthread} -test iortrans.tf-7.2 {seek clears read buffers} -match glob -body { +} -result {{clear rt*} {write rt* snarf}} +test iortrans.tf-7.2 {seek clears read buffers} -setup { set res {} +} -constraints {testchannel testthread} -match glob -body { proc foo {args} { - oninit clear; onfinal; track + handle.initialize clear + handle.finalize + lappend ::res $args return } set c [chan push [tempchan] foo] @@ -1414,14 +1700,18 @@ test iortrans.tf-7.2 {seek clears read buffers} -match glob -body { seek $c 2 close $c } c + return $res +} -cleanup { tempdone rename foo {} - set res -} -result {{clear rt*}} -constraints {testchannel testthread} -test iortrans.tf-7.3 {clear, any result is ignored} -match glob -body { +} -result {{clear rt*}} +test iortrans.tf-7.3 {clear, any result is ignored} -setup { set res {} +} -constraints {testchannel testthread} -match glob -body { proc foo {args} { - oninit clear; onfinal; track + handle.initialize clear + handle.finalize + lappend ::res $args return -code error "X" } set c [chan push [tempchan] foo] @@ -1429,56 +1719,60 @@ test iortrans.tf-7.3 {clear, any result is ignored} -match glob -body { seek $c 2 close $c } c + return $res +} -cleanup { tempdone rename foo {} - set res -} -result {{clear rt*}} -constraints {testchannel testthread} +} -result {{clear rt*}} # --- === *** ########################### # method flush (via seek, close) -test iortrans.tf-8.1 {seek flushes write buffers, ignores data} -match glob -body { +test iortrans.tf-8.1 {seek flushes write buffers, ignores data} -setup { set res {} +} -constraints {testchannel testthread} -match glob -body { proc foo {args} { - oninit flush; onfinal; track + handle.initialize flush + handle.finalize + lappend ::res $args return X } set c [chan push [tempchan] foo] - notes [inthread $c { + lappend res {*}[inthread $c { # Flush, no writing seek $c 2 # The close flushes again, this modifies the file! - note | ; note [close $c] ; note | - # NOTE: The flush generated by the close is recorded - # immediately, the other note's here are defered until after - # the thread is done. This changes the order of the result a - # bit from the non-threaded case (The first | moves one to the - # right). This is an artifact of the 'inthread' framework, not - # of the transformation itself. + 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] - note [tempview] + lappend res [tempview] +} -cleanup { tempdone rename foo {} - set res -} -result {{flush rt*} {flush rt*} | {} | {teXt data}} -constraints {testchannel testthread} - -test iortrans.tf-8.2 {close flushes write buffers, writes data} -match glob -body { +} -result {{flush rt*} {flush rt*} | {} | {teXt data}} +test iortrans.tf-8.2 {close flushes write buffers, writes data} -setup { set res {} +} -constraints {testchannel testthread} -match glob -body { proc foo {args} { - oninit flush; track ; onfinal + handle.initialize flush + lappend ::res $args + handle.finalize return .flushed. } set c [chan push [tempchan] foo] inthread $c { close $c } c - note [tempview] + lappend res [tempview] +} -cleanup { tempdone rename foo {} - set res -} -result {{flush rt*} {finalize rt*} .flushed.} -constraints {testchannel testthread} - +} -result {{flush rt*} {finalize rt*} .flushed.} # --- === *** ########################### # method watch - removed from TIP (rev 1.12+) @@ -1487,97 +1781,89 @@ test iortrans.tf-8.2 {close flushes write buffers, writes data} -match glob -bod # method event - removed from TIP (rev 1.12+) # --- === *** ########################### -# 'Pull the rug' tests. Create channel in a thread A, move to other -# thread B, destroy the origin thread (A) before or during access from -# B. Must not crash, must return proper errors. - -test iortrans.tf-11.0 {origin thread of moved transform gone} -match glob -body { +# '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 [testthread create];#puts <<$tida>> - set tidb [testthread create];#puts <<$tidb>> - + set tida [testthread create]; #puts <<$tida>> + set tidb [testthread create]; #puts <<$tidb>> +} -constraints {testchannel testthread} -match glob -body { # Set up channel in thread testthread send $tida $helperscript set chan [testthread send $tida { - proc foo {args} {oninit clear drain flush limit? read write; onfinal; track; return} + 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. - testthread send $tida [list testchannel cut $chan] + testthread send $tida [list testchannel cut $chan] testthread send $tidb [list testchannel splice $chan] - # Kill origin thread, then access channel from 2nd thread. testthread send -async $tida {testthread exit} - after 100 - - set res {} - lappend res [catch {testthread send $tidb [list puts $chan shoo]} msg] $msg - lappend res [catch {testthread send $tidb [list tell $chan]} msg] $msg - lappend res [catch {testthread send $tidb [list seek $chan 1]} msg] $msg - lappend res [catch {testthread send $tidb [list gets $chan]} msg] $msg - lappend res [catch {testthread send $tidb [list close $chan]} msg] $msg - tcltest::threadReap - tempdone - set res + after 50 + set res {} + lappend res [catch {testthread send $tidb [list puts $chan shoo]} msg] $msg + lappend res [catch {testthread send $tidb [list tell $chan]} msg] $msg + lappend res [catch {testthread send $tidb [list seek $chan 1]} msg] $msg + lappend res [catch {testthread send $tidb [list gets $chan]} msg] $msg + lappend res [catch {testthread send $tidb [list close $chan]} msg] $msg # The 'tell' is ok, as it passed through the transform to the base # channel without invoking the transform handler. - -} -constraints {testchannel testthread} \ - -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} - -test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} -match glob -body { - +} -cleanup { + tcltest::threadReap + tempdone +} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} +test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} -setup { #puts <<$tcltest::mainThread>>main - set tida [testthread create];#puts <<$tida>> - set tidb [testthread create];#puts <<$tidb>> - + set tida [testthread create]; #puts <<$tida>> + set tidb [testthread create]; #puts <<$tidb>> +} -constraints {testchannel testthread} -match glob -body { # Set up channel in thread set chan [testthread send $tida $helperscript] set chan [testthread send $tida { proc foo {args} { - oninit clear drain flush limit? read write; onfinal; track; + handle.initialize clear drain flush limit? read write + handle.finalize + lappend ::res $args # destroy thread during channel access testthread exit - return} + return + } set chan [chan push [tempchan] foo] fconfigure $chan -buffering none set chan }] - # Move channel to 2nd thread, transform goes with it. - testthread send $tida [list testchannel cut $chan] + testthread send $tida [list testchannel cut $chan] testthread send $tidb [list testchannel splice $chan] - - # Run access from thread B, wait for response from A (A is not - # using event loop at this point, so the event pile up in the - # queue. - + # Run access from thread B, wait for response from A (A is not using event + # loop at this point, so the event pile up in the queue. testthread send $tidb [list set chan $chan] testthread send $tidb [list set mid $tcltest::mainThread] testthread send -async $tidb { - # wait a bit, give the main thread the time to start its event - # loop to wait for the response from B - after 2000 + # 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 } testthread send -async $mid [list set ::res $res] } vwait ::res - + return $res +} -cleanup { tcltest::threadReap tempdone - set res -} -constraints {testchannel testthread} \ - -result {Owner lost} - -# ### ### ### ######### ######### ######### - +} -result {Owner lost} + # ### ### ### ######### ######### ######### -rename track {} cleanupTests return diff --git a/tests/iogt.test b/tests/iogt.test index c45d97d..40f6b82 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -3,14 +3,14 @@ # # This file contains a collection of tests for Giot # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 2000 Ajuba Solutions. # Copyright (c) 2000 Andreas Kupries. # All rights reserved. # -# RCS: @(#) $Id: iogt.test,v 1.16 2006/11/03 11:45:34 dkf Exp $ +# RCS: @(#) $Id: iogt.test,v 1.17 2010/11/24 11:56:57 dkf Exp $ if {[catch {package require tcltest 2.1}]} { puts stderr "Skipping tests in [info script]. tcltest 2.1 required." @@ -38,41 +38,38 @@ set path(__echo_srv__.tcl) [makeFile { # delay between blocks # blocksize ... -set port [lindex $argv 0] +set port [lindex $argv 0] set fdelay [lindex $argv 1] set idelay [lindex $argv 2] set bsizes [lrange $argv 3 end] -set c 0 +set c 0 proc newconn {sock rhost rport} { variable fdelay variable c - incr c - variable c$c + incr c + namespace upvar [namespace current] c$c conn #puts stdout "C $sock $rhost $rport / $fdelay" ; flush stdout - upvar 0 c$c conn set conn(after) {} set conn(state) 0 - set conn(size) 0 - set conn(data) "" + set conn(size) 0 + set conn(data) "" set conn(delay) $fdelay - fileevent $sock readable [list echoGet $c $sock] + fileevent $sock readable [list echoGet $c $sock] fconfigure $sock -translation binary -buffering none -blocking 0 } proc echoGet {c sock} { variable fdelay - variable c$c - upvar 0 c$c conn + namespace upvar [namespace current] c$c conn if {[eof $sock]} { # one-shot echo exit } - append conn(data) [read $sock] #puts stdout "G $c $sock $conn(data) <<$conn(data)>>" ; flush stdout @@ -86,8 +83,7 @@ proc echoPut {c sock} { variable idelay variable fdelay variable bsizes - variable c$c - upvar 0 c$c conn + namespace upvar [namespace current] c$c conn if {[string length $conn(data)] == 0} { #puts stdout "C $c $sock" ; flush stdout @@ -98,9 +94,7 @@ proc echoPut {c sock} { return } - set conn(delay) $idelay - set n [lindex $bsizes $conn(size)] #puts stdout "P $c $sock $n >>" ; flush stdout @@ -109,7 +103,6 @@ proc echoPut {c sock} { #parray conn #puts n=<$n> - if {[string length $conn(data)] >= $n} { puts -nonewline $sock [string range $conn(data) 0 $n] set conn(data) [string range $conn(data) [incr n] end] @@ -130,40 +123,33 @@ socket -server newconn -myaddr 127.0.0.1 $port vwait forever } __echo_srv__.tcl] - ######################################################################## proc fevent {fdelay idelay blocks script data} { - # start and initialize an echo server, prepare data - # transmission, then hand over to the test script. - # this has to start real transmission via 'flush'. - # The server is stopped after completion of the test. + # Start and initialize an echo server, prepare data transmission, then + # hand over to the test script. This has to start real transmission via + # 'flush'. The server is stopped after completion of the test. - # fixed port, not so good. lets hope for the best, for now. - set port 4000 + upvar 1 sock sk - exec tclsh __echo_srv__.tcl \ - $port $fdelay $idelay {*}$blocks >@stdout & + # Fixed port, not so good. Lets hope for the best, for now. + set port 4000 + exec tclsh __echo_srv__.tcl $port $fdelay $idelay {*}$blocks >@stdout & after 500 - #puts stdout "> $port" ; flush stdout - - set sk [socket localhost $port] - fconfigure $sk \ - -blocking 0 \ - -buffering full \ - -buffersize [expr {10+[llength $data]}] + #puts stdout "> $port"; flush stdout + set sk [socket localhost $port] + fconfigure $sk -blocking 0 -buffering full \ + -buffersize [expr {10+[llength $data]}] puts -nonewline $sk $data # The channel is prepared to go off. - #puts stdout ">>>>>" ; flush stdout - - uplevel #0 set sock $sk - set res [uplevel #0 $script] + #puts stdout ">>>>>"; flush stdout + set res [uplevel 1 $script] catch {close $sk} return $res } @@ -173,18 +159,15 @@ proc fevent {fdelay idelay blocks script data} { proc id {op data} { switch -- $op { - create/write - - create/read - - delete/write - - delete/read - - clear_read {;#ignore} - flush/write - - flush/read - - write - - read { + create/write - create/read - delete/write - delete/read - clear_read { + #ignore + } + flush/write - flush/read - write - read { return $data } - query/maxRead {return -1} + query/maxRead { + return -1 + } } } @@ -193,43 +176,34 @@ proc id_optrail {var op data} { upvar 0 $var trail lappend trail $op - switch -- $op { - create/write - create/read - - delete/write - delete/read - - flush/read - - clear/read { #ignore } - flush/write - - write - - read { + create/write - create/read - delete/write - delete/read - + flush/read - clear/read { + #ignore + } + flush/write - write - read { return $data } - query/maxRead { + query/maxRead { return -1 } - default { + default { lappend trail "error $op" error $op } } } - proc id_fulltrail {var op data} { - variable $var - upvar 0 $var trail + namespace upvar [namespace current] $var trail #puts stdout ">> $var $op $data" ; flush stdout switch -- $op { - create/write - create/read - - delete/write - delete/read - - clear_read { + create/write - create/read - delete/write - delete/read - clear_read { set res *ignored* } - flush/write - flush/read - - write - - read { + flush/write - flush/read - write - read { set res $data } query/maxRead { @@ -245,18 +219,19 @@ proc id_fulltrail {var op data} { } proc counter {var op data} { - variable $var - upvar 0 $var n + namespace upvar [namespace current] $var n switch -- $op { - create/write - create/read - - delete/write - delete/read - - clear_read {;#ignore} - flush/write - flush/read {return {}} + create/write - create/read - delete/write - delete/read - clear_read { + #ignore + } + flush/write - flush/read { + return {} + } write { return $data } - read { + read { if {$n > 0} { incr n -[string length $data] if {$n < 0} { @@ -271,25 +246,20 @@ proc counter {var op data} { } } - proc counter_audit {var vtrail op data} { - variable $var - variable $vtrail - upvar 0 $var n $vtrail trail + namespace upvar [namespace current] $var n $vtrail trail switch -- $op { - create/write - create/read - - delete/write - delete/read - - clear_read { + create/write - create/read - delete/write - delete/read - clear_read { set res {} } - flush/write - flush/read { + flush/write - flush/read { set res {} } write { set res $data } - read { + read { if {$n > 0} { incr n -[string length $data] if {$n < 0} { @@ -307,36 +277,28 @@ proc counter_audit {var vtrail op data} { return $res } - proc rblocks {var vtrail n op data} { - variable $var - variable $vtrail - upvar 0 $var buf $vtrail trail + namespace upvar [namespace current] $var n $vtrail trail set res {} switch -- $op { - create/write - create/read - - delete/write - delete/read - - clear_read { + create/write - create/read - delete/write - delete/read - clear_read { set buf {} } flush/write { } - flush/read { + flush/read { set res $buf set buf {} } - write { + write { set data } - read { + read { append buf $data - set b [expr {$n * ([string length $buf] / $n)}] - append op " $n [string length $buf] :- $b" - set res [string range $buf 0 [incr b -1]] set buf [string range $buf [incr b] end] #return $res @@ -350,36 +312,28 @@ proc rblocks {var vtrail n op data} { return $res } - # -------------------------------------------------------------- # ... and convenience procedures to stack them proc identity {-attach channel} { testchannel transform $channel -command [namespace code id] } - proc audit_ops {var -attach channel} { testchannel transform $channel -command [namespace code [list id_optrail $var]] } - proc audit_flow {var -attach channel} { testchannel transform $channel -command [namespace code [list id_fulltrail $var]] } - proc stopafter {var n -attach channel} { - variable $var - upvar 0 $var vn + namespace upvar [namespace current] $var vn set vn $n testchannel transform $channel -command [namespace code [list counter $var]] } - proc stopafter_audit {var trail n -attach channel} { - variable $var - upvar 0 $var vn + namespace upvar [namespace current] $var vn set vn $n testchannel transform $channel -command [namespace code [list counter_audit $var $trail]] } - proc rblocks_t {var trail n -attach channel} { testchannel transform $channel -command [namespace code [list rblocks $var $trail $n]] } @@ -389,36 +343,31 @@ proc rblocks_t {var trail n -attach channel} { proc array_sget {v} { upvar $v a - set res [list] foreach n [lsort [array names a]] { lappend res $n $a($n) } set res } - proc asort {alist} { # sort a list of key/value pairs by key, removes duplicates too. - - array set a $alist + array set a $alist array_sget a } - + ######################################################################## test iogt-1.1 {stack/unstack} testchannel { set fh [open $path(dummy) r] identity -attach $fh testchannel unstack $fh - close $fh + close $fh } {} - test iogt-1.2 {stack/close} testchannel { set fh [open $path(dummy) r] identity -attach $fh - close $fh + close $fh } {} - test iogt-1.3 {stack/unstack, configuration, options} testchannel { set fh [open $path(dummy) r] set ca [asort [fconfigure $fh]] @@ -427,79 +376,53 @@ test iogt-1.3 {stack/unstack, configuration, options} testchannel { testchannel unstack $fh set cc [asort [fconfigure $fh]] close $fh - - # With this system none of the buffering, translation and - # encoding option may change their values with channels - # stacked upon each other or not. - + # With this system none of the buffering, translation and encoding option + # may change their values with channels stacked upon each other or not. # cb == ca == cc - list [string equal $ca $cb] [string equal $cb $cc] [string equal $ca $cc] } {1 1 1} - -test iogt-1.4 {stack/unstack, configuration} testchannel { +test iogt-1.4 {stack/unstack, configuration} -setup { set fh [open $path(dummy) r] +} -constraints testchannel -body { set ca [asort [fconfigure $fh]] identity -attach $fh - fconfigure $fh \ - -buffering line \ - -translation cr \ - -encoding shiftjis + fconfigure $fh -buffering line -translation cr -encoding shiftjis testchannel unstack $fh set cc [asort [fconfigure $fh]] - - set res [list \ - [string equal $ca $cc] \ - [fconfigure $fh -buffering] \ - [fconfigure $fh -translation] \ - [fconfigure $fh -encoding] \ - ] - + list [string equal $ca $cc] [fconfigure $fh -buffering] \ + [fconfigure $fh -translation] [fconfigure $fh -encoding] +} -cleanup { close $fh - set res -} {0 line cr shiftjis} +} -result {0 line cr shiftjis} -test iogt-2.0 {basic I/O going through transform} testchannel { - set fin [open $path(dummy) r] +test iogt-2.0 {basic I/O going through transform} -setup { + set fin [open $path(dummy) r] set fout [open $path(dummyout) w] - +} -constraints testchannel -body { identity -attach $fin identity -attach $fout - fcopy $fin $fout - close $fin close $fout - - set fin [open $path(dummy) r] + set fin [open $path(dummy) r] set fout [open $path(dummyout) r] - - set res [string equal [set in [read $fin]] [set out [read $fout]]] - lappend res [string length $in] [string length $out] - + list [string equal [set in [read $fin]] [set out [read $fout]]] \ + [string length $in] [string length $out] +} -cleanup { close $fin close $fout - - set res -} {1 71 71} - - +} -result {1 71 71} test iogt-2.1 {basic I/O, operation trail} {testchannel unix} { - set fin [open $path(dummy) r] + set fin [open $path(dummy) r] set fout [open $path(dummyout) w] - - set ain [list] ; set aout [list] - audit_ops ain -attach $fin + set ain [list]; set aout [list] + audit_ops ain -attach $fin audit_ops aout -attach $fout - - fconfigure $fin -buffersize 10 + fconfigure $fin -buffersize 10 fconfigure $fout -buffersize 10 - fcopy $fin $fout - close $fin close $fout - set res "[join $ain \n]\n--------\n[join $aout \n]" } {create/read query/maxRead @@ -533,23 +456,17 @@ write write flush/write delete/write} - test iogt-2.2 {basic I/O, data trail} {testchannel unix} { - set fin [open $path(dummy) r] + set fin [open $path(dummy) r] set fout [open $path(dummyout) w] - - set ain [list] ; set aout [list] - audit_flow ain -attach $fin + set ain [list]; set aout [list] + audit_flow ain -attach $fin audit_flow aout -attach $fout - - fconfigure $fin -buffersize 10 + fconfigure $fin -buffersize 10 fconfigure $fout -buffersize 10 - fcopy $fin $fout - close $fin close $fout - set res "[join $ain \n]\n--------\n[join $aout \n]" } {create/read {} *ignored* query/maxRead {} -1 @@ -587,24 +504,17 @@ write { } flush/write {} {} delete/write {} *ignored*} - - test iogt-2.3 {basic I/O, mixed trail} {testchannel unix} { - set fin [open $path(dummy) r] + set fin [open $path(dummy) r] set fout [open $path(dummyout) w] - set trail [list] audit_flow trail -attach $fin audit_flow trail -attach $fout - - fconfigure $fin -buffersize 20 + fconfigure $fin -buffersize 20 fconfigure $fout -buffersize 10 - fcopy $fin $fout - close $fin close $fout - join $trail \n } {create/read {} *ignored* create/write {} *ignored* @@ -634,110 +544,80 @@ delete/read {} *ignored* flush/write {} {} delete/write {} *ignored*} - -test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} \ - {testchannel unknownFailure} { - # This test to check the validity of aquired Tcl_Channel references is - # not possible because even a backgrounded fcopy will immediately start - # to copy data, without waiting for the event loop. This is done only in - # case of an underflow on the read size!. So stacking transforms after the +test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup { + proc DoneCopy {n {err {}}} { + variable copy 1 + } +} -constraints {testchannel hangs} -body { + # This test to check the validity of aquired Tcl_Channel references is not + # possible because even a backgrounded fcopy will immediately start to + # copy data, without waiting for the event loop. This is done only in case + # of an underflow on the read size!. So stacking transforms after the # fcopy will miss information, or are not used at all. # # I was able to circumvent this by using the echo.tcl server with a big # delay, causing the fcopy to underflow immediately. - - proc DoneCopy {n {err {}}} { - variable copy ; set copy 1 - } - - set fin [open $path(dummy) r] - + set fin [open $path(dummy) r] fevent 1000 500 {20 20 20 10 1 1} { close $fin - - set fout [open dummyout w] - - flush $sock ; # now, or fcopy will error us out - # But the 1 second delay should be enough to - # initialize everything else here. - + set fout [open dummyout w] + flush $sock; # now, or fcopy will error us out + # But the 1 second delay should be enough to initialize everything + # else here. fcopy $sock $fout -command [namespace code DoneCopy] - - # transform after fcopy got its handles ! - # They should be still valid for fcopy. - + # Transform after fcopy got its handles! They should be still valid + # for fcopy. set trail [list] audit_ops trail -attach $fout - vwait [namespace which -variable copy] - } [read $fin] ; # {} - + } [read $fin]; # {} close $fout - - rename DoneCopy {} - # Check result of copy. - - set fin [open $path(dummy) r] + set fin [open $path(dummy) r] set fout [open $path(dummyout) r] - set res [string equal [read $fin] [read $fout]] - close $fin close $fout - list $res $trail -} {1 {create/write create/read write flush/write flush/read delete/write delete/read}} - +} -cleanup { + rename DoneCopy {} +} -result {1 {create/write create/read write flush/write flush/read delete/write delete/read}} -test iogt-4.0 {fileevent readable, after transform} {testchannel unknownFailure} { - set fin [open $path(dummy) r] +test iogt-4.0 {fileevent readable, after transform} -setup { + set fin [open $path(dummy) r] set data [read $fin] close $fin - set trail [list] - set got [list] - + set got [list] proc Done {args} { - variable stop - set stop 1 + variable stop 1 } - - proc Get {sock} { - variable trail - variable got - if {[eof $sock]} { - Done - lappend trail "xxxxxxxxxxxxx" - close $sock - return - } - lappend trail "vvvvvvvvvvvvv" - lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]" - lappend trail "=============" - #puts stdout $__ ; flush stdout - #read $sock - } - +} -constraints {testchannel hangs} -body { fevent 1000 500 {20 20 20 10 1} { - audit_flow trail -attach $sock - rblocks_t rbuf trail 23 -attach $sock - - fileevent $sock readable [list Get $sock] - - flush $sock ; # now, or fcopy will error us out - # But the 1 second delay should be enough to - # initialize everything else here. - + audit_flow trail -attach $sock + rblocks_t rbuf trail 23 -attach $sock + fileevent $sock readable [namespace code { + if {[eof $sock]} { + Done + lappend trail "xxxxxxxxxxxxx" + close $sock + } else { + lappend trail "vvvvvvvvvvvvv" + lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]" + lappend trail "=============" + #puts stdout $__; flush stdout + #read $sock + } + }] + flush $sock; # Now, or fcopy will error us out + # But the 1 second delay should be enough to initialize everything + # else here. vwait [namespace which -variable stop] } $data - - - rename Done {} - rename Get {} - join [list [join $got \n] ~~~~~~~~ [join $trail \n]] \n -} {[[]] +} -cleanup { + rename Done {} +} -result {[[]] [[abcdefghijklmnopqrstuvw]] [[xyz0123456789,./?><;'\|]] [[]] @@ -818,35 +698,27 @@ rblock | delete/write {} {} | {} rblock | delete/read {} {} | {} flush/write {} {} delete/write {} *ignored* -delete/read {} *ignored*} ; # catch unescaped quote " +delete/read {} *ignored*}; # catch unescaped quote " - -test iogt-5.0 {EOF simulation} {testchannel unknownFailure} { - set fin [open $path(dummy) r] +test iogt-5.0 {EOF simulation} -setup { + set fin [open $path(dummy) r] set fout [open $path(dummyout) w] - set trail [list] - +} -constraints {testchannel unknownFailure} -result { audit_flow trail -attach $fin - stopafter_audit d trail 20 -attach $fin + stopafter_audit d trail 20 -attach $fin audit_flow trail -attach $fout - - fconfigure $fin -buffersize 20 + fconfigure $fin -buffersize 20 fconfigure $fout -buffersize 10 - - fcopy $fin $fout + fcopy $fin $fout testchannel unstack $fin - # now copy the rest in the channel lappend trail {**after unstack**} - fcopy $fin $fout - close $fin close $fout - join $trail \n -} {create/read {} *ignored* +} -result {create/read {} *ignored* counter:create/read {} {} create/write {} *ignored* counter:query/maxRead {} 20 @@ -880,59 +752,48 @@ delete/write {} *ignored*} proc constX {op data} { # replace anything coming in with a same-length string of x'es. switch -- $op { - create/write - create/read - - delete/write - delete/read - - clear_read {;#ignore} - flush/write - flush/read - - write - - read { + create/write - create/read - delete/write - delete/read - clear_read { + #ignore + } + flush/write - flush/read - write - read { return [string repeat x [string length $data]] } - query/maxRead {return -1} + query/maxRead { + return -1 + } } } - proc constx {-attach channel} { testchannel transform $channel -command [namespace code constX] } -test iogt-6.0 {Push back} testchannel { +test iogt-6.0 {Push back} -constraints testchannel -body { set f [open $path(dummy) r] - # contents of dummy = "abcdefghi..." - read $f 3 ; # skip behind "abc" - + read $f 3; # skip behind "abc" constx -attach $f - - # expect to get "xxx" from the transform because - # of unread "def" input to transform which returns "xxx". + # expect to get "xxx" from the transform because of unread "def" input to + # transform which returns "xxx". # - # Actually the IO layer pre-read the whole file and will - # read "def" directly from the buffer without bothering - # to consult the newly stacked transformation. This is - # wrong. - - set res [read $f 3] + # Actually the IO layer pre-read the whole file and will read "def" + # directly from the buffer without bothering to consult the newly stacked + # transformation. This is wrong. + read $f 3 +} -cleanup { close $f - set res -} {xxx} - -test iogt-6.1 {Push back and up} {testchannel knownBug} { +} -result {xxx} +test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body { set f [open $path(dummy) r] - # contents of dummy = "abcdefghi..." - read $f 3 ; # skip behind "abc" - + read $f 3; # skip behind "abc" constx -attach $f set res [read $f 3] - testchannel unstack $f append res [read $f 3] +} -cleanup { close $f - set res -} {xxxghi} - - +} -result {xxxghi} + # cleanup foreach file [list dummy dummyout __echo_srv__.tcl] { removeFile $file |