summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/chanio.test523
-rw-r--r--tests/ioTrans.test1676
-rw-r--r--tests/iogt.test477
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