summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authorKevin B Kenny <kennykb@acm.org>2010-12-01 16:42:33 (GMT)
committerKevin B Kenny <kennykb@acm.org>2010-12-01 16:42:33 (GMT)
commit921c2612861d68b7b4eee66736379431ac081f30 (patch)
tree47091361dfd1c093c24bb1dc06082c6dc469eaad /tests
parent86b28e0c4b2444435a30d345b3fe26daaf9de126 (diff)
downloadtcl-921c2612861d68b7b4eee66736379431ac081f30.zip
tcl-921c2612861d68b7b4eee66736379431ac081f30.tar.gz
tcl-921c2612861d68b7b4eee66736379431ac081f30.tar.bz2
merge
Diffstat (limited to 'tests')
-rw-r--r--tests/chanio.test4001
-rw-r--r--tests/error.test68
-rw-r--r--tests/info.test143
-rw-r--r--tests/interp.test54
-rw-r--r--tests/ioTrans.test1676
-rw-r--r--tests/iogt.test477
-rw-r--r--tests/main.test14
-rw-r--r--tests/oo.test73
-rw-r--r--tests/remote.tcl3
-rw-r--r--tests/socket.test389
-rw-r--r--tests/util.test803
11 files changed, 4518 insertions, 3183 deletions
diff --git a/tests/chanio.test b/tests/chanio.test
index c1dba49..11bf23e 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.23 2010/02/07 08:03:11 dkf Exp $
+# RCS: @(#) $Id: chanio.test,v 1.23.4.1 2010/12/01 16:42:36 kennykb 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.
@@ -183,17 +188,17 @@ test chan-io-2.2 {WriteBytes: savedLF > 0} {
chan close $f
lappend x [contents $path(test1)]
} [list "123456789012345\r" "123456789012345\r\n12"]
-test chan-io-2.3 {WriteBytes: flush on line} {
- # 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.
+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.
set f [open $path(test1) w]
chan configure $f -encoding binary -buffering line -translation crlf
chan puts -nonewline $f "\n12"
- set x [contents $path(test1)]
+ contents $path(test1)
+} -cleanup {
chan close $f
- set x
-} "\r\n12"
+} -result "\r\n12"
test chan-io-2.4 {WriteBytes: reset sawLF after each buffer} {
set f [open $path(test1) w]
chan configure $f -encoding binary -buffering line -translation lf \
@@ -222,17 +227,17 @@ test chan-io-3.2 {WriteChars: compatibility with WriteBytes: savedLF > 0} {
chan close $f
lappend x [contents $path(test1)]
} [list "123456789012345\r" "123456789012345\r\n12"]
-test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} {
- # 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.
+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.
set f [open $path(test1) w]
chan configure $f -encoding ascii -buffering line -translation crlf
chan puts -nonewline $f "\n12"
- set x [contents $path(test1)]
+ contents $path(test1)
+} -cleanup {
chan close $f
- set x
-} "\r\n12"
+} -result "\r\n12"
test chan-io-3.4 {WriteChars: loop over stage buffer} {
# stage buffer maps to more than can be queued at once.
set f [open $path(test1) w]
@@ -380,118 +385,118 @@ test chan-io-5.5 {CheckFlush: none} {
lappend x [contents $path(test1)]
} [list "1234567890" "1234567890"]
-test chan-io-6.1 {Tcl_GetsObj: working} {
+test chan-io-6.1 {Tcl_GetsObj: working} -body {
set f [open $path(test1) w]
chan puts $f "foo\nboo"
chan close $f
set f [open $path(test1)]
- set x [chan gets $f]
+ chan gets $f
+} -cleanup {
chan close $f
- set x
-} {foo}
+} -result {foo}
test chan-io-6.2 {Tcl_GetsObj: CheckChannelErrors() != 0} emptyTest {
# no test, need to cause an async error.
} {}
-test chan-io-6.3 {Tcl_GetsObj: how many have we used?} {
+test chan-io-6.3 {Tcl_GetsObj: how many have we used?} -body {
# if (bufPtr != NULL) {oldRemoved = bufPtr->nextRemoved}
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f "abc\ndefg"
chan close $f
set f [open $path(test1)]
- set x [list [chan tell $f] [chan gets $f line] [chan tell $f] [chan gets $f line] $line]
+ list [chan tell $f] [chan gets $f line] [chan tell $f] [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} {0 3 5 4 defg}
-test chan-io-6.4 {Tcl_GetsObj: encoding == NULL} {
+} -result {0 3 5 4 defg}
+test chan-io-6.4 {Tcl_GetsObj: encoding == NULL} -body {
set f [open $path(test1) w]
chan configure $f -translation binary
chan puts $f "\x81\u1234\0"
chan close $f
set f [open $path(test1)]
chan configure $f -translation binary
- set x [list [chan gets $f line] $line]
+ list [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list 3 "\x81\x34\x00"]
-test chan-io-6.5 {Tcl_GetsObj: encoding != NULL} {
+} -result [list 3 "\x81\x34\x00"]
+test chan-io-6.5 {Tcl_GetsObj: encoding != NULL} -body {
set f [open $path(test1) w]
chan configure $f -translation binary
chan puts $f "\x88\xea\x92\x9a"
chan close $f
set f [open $path(test1)]
chan configure $f -encoding shiftjis
- set x [list [chan gets $f line] $line]
+ list [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list 2 "\u4e00\u4e01"]
+} -result [list 2 "\u4e00\u4e01"]
set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
append a $a
append a $a
-test chan-io-6.6 {Tcl_GetsObj: loop test} {
+test chan-io-6.6 {Tcl_GetsObj: loop test} -body {
# if (dst >= dstEnd)
set f [open $path(test1) w]
chan puts $f $a
chan puts $f hi
chan close $f
set f [open $path(test1)]
- set x [list [chan gets $f line] $line]
+ list [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list 256 $a]
-test chan-io-6.7 {Tcl_GetsObj: error in input} {stdio openpipe} {
+} -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
chan configure $f -blocking 0
- set x [chan gets $f line]
+ chan gets $f line
+} -cleanup {
chan close $f
- set x
-} {-1}
-test chan-io-6.8 {Tcl_GetsObj: remember if EOF is seen} {
+} -result {-1}
+test chan-io-6.8 {Tcl_GetsObj: remember if EOF is seen} -body {
set f [open $path(test1) w]
chan puts $f "abcdef\x1aghijk\nwombat"
chan close $f
set f [open $path(test1)]
chan configure $f -eofchar \x1a
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} {6 abcdef -1 {}}
-test chan-io-6.9 {Tcl_GetsObj: remember if EOF is seen} {
+} -result {6 abcdef -1 {}}
+test chan-io-6.9 {Tcl_GetsObj: remember if EOF is seen} -body {
set f [open $path(test1) w]
chan puts $f "abcdefghijk\nwom\u001abat"
chan close $f
set f [open $path(test1)]
chan configure $f -eofchar \x1a
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} {11 abcdefghijk 3 wom}
+} -result {11 abcdefghijk 3 wom}
# Comprehensive tests
-test chan-io-6.10 {Tcl_GetsObj: lf mode: no chars} {
+test chan-io-6.10 {Tcl_GetsObj: lf mode: no chars} -body {
set f [open $path(test1) w]
chan close $f
set f [open $path(test1)]
chan configure $f -translation lf
- set x [list [chan gets $f line] $line]
+ list [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} {-1 {}}
-test chan-io-6.11 {Tcl_GetsObj: lf mode: lone \n} {
+} -result {-1 {}}
+test chan-io-6.11 {Tcl_GetsObj: lf mode: lone \n} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "\n"
chan close $f
set f [open $path(test1)]
chan configure $f -translation lf
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} {0 {} -1 {}}
-test chan-io-6.12 {Tcl_GetsObj: lf mode: lone \r} {
+} -result {0 {} -1 {}}
+test chan-io-6.12 {Tcl_GetsObj: lf mode: lone \r} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "\r"
@@ -499,193 +504,194 @@ test chan-io-6.12 {Tcl_GetsObj: lf mode: lone \r} {
set f [open $path(test1)]
chan configure $f -translation lf
set x [list [chan gets $f line] $line [chan gets $f line] $line]
+} -cleanup {
chan close $f
- set x
-} [list 1 "\r" -1 ""]
-test chan-io-6.13 {Tcl_GetsObj: lf mode: 1 char} {
+} -result [list 1 "\r" -1 ""]
+test chan-io-6.13 {Tcl_GetsObj: lf mode: 1 char} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f a
chan close $f
set f [open $path(test1)]
chan configure $f -translation lf
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} {1 a -1 {}}
-test chan-io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} {
+} -result {1 a -1 {}}
+test chan-io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "a\n"
chan close $f
set f [open $path(test1)]
chan configure $f -translation lf
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} {1 a -1 {}}
-test chan-io-6.15 {Tcl_GetsObj: lf mode: several chars} {
+} -result {1 a -1 {}}
+test chan-io-6.15 {Tcl_GetsObj: lf mode: several chars} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
chan close $f
set f [open $path(test1)]
chan configure $f -translation lf
- set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line \
+ [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list 4 "abcd" 10 "efgh\rijkl\r" 4 "mnop" -1 ""]
-test chan-io-6.16 {Tcl_GetsObj: cr mode: no chars} {
+} -result [list 4 "abcd" 10 "efgh\rijkl\r" 4 "mnop" -1 ""]
+test chan-io-6.16 {Tcl_GetsObj: cr mode: no chars} -body {
set f [open $path(test1) w]
chan close $f
set f [open $path(test1)]
chan configure $f -translation cr
- set x [list [chan gets $f line] $line]
+ list [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} {-1 {}}
-test chan-io-6.17 {Tcl_GetsObj: cr mode: lone \n} {
+} -result {-1 {}}
+test chan-io-6.17 {Tcl_GetsObj: cr mode: lone \n} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "\n"
chan close $f
set f [open $path(test1)]
chan configure $f -translation cr
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list 1 "\n" -1 ""]
-test chan-io-6.18 {Tcl_GetsObj: cr mode: lone \r} {
+} -result [list 1 "\n" -1 ""]
+test chan-io-6.18 {Tcl_GetsObj: cr mode: lone \r} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "\r"
chan close $f
set f [open $path(test1)]
chan configure $f -translation cr
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} {0 {} -1 {}}
-test chan-io-6.19 {Tcl_GetsObj: cr mode: 1 char} {
+} -result {0 {} -1 {}}
+test chan-io-6.19 {Tcl_GetsObj: cr mode: 1 char} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f a
chan close $f
set f [open $path(test1)]
chan configure $f -translation cr
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} {1 a -1 {}}
-test chan-io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} {
+} -result {1 a -1 {}}
+test chan-io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "a\r"
chan close $f
set f [open $path(test1)]
chan configure $f -translation cr
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} {1 a -1 {}}
-test chan-io-6.21 {Tcl_GetsObj: cr mode: several chars} {
+} -result {1 a -1 {}}
+test chan-io-6.21 {Tcl_GetsObj: cr mode: several chars} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
chan close $f
set f [open $path(test1)]
chan configure $f -translation cr
- set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list 9 "abcd\nefgh" 4 "ijkl" 5 "\nmnop" -1 ""]
-test chan-io-6.22 {Tcl_GetsObj: crlf mode: no chars} {
+} -result [list 9 "abcd\nefgh" 4 "ijkl" 5 "\nmnop" -1 ""]
+test chan-io-6.22 {Tcl_GetsObj: crlf mode: no chars} -body {
set f [open $path(test1) w]
chan close $f
set f [open $path(test1)]
chan configure $f -translation crlf
- set x [list [chan gets $f line] $line]
+ list [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} {-1 {}}
-test chan-io-6.23 {Tcl_GetsObj: crlf mode: lone \n} {
+} -result {-1 {}}
+test chan-io-6.23 {Tcl_GetsObj: crlf mode: lone \n} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "\n"
chan close $f
set f [open $path(test1)]
chan configure $f -translation crlf
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list 1 "\n" -1 ""]
-test chan-io-6.24 {Tcl_GetsObj: crlf mode: lone \r} {
+} -result [list 1 "\n" -1 ""]
+test chan-io-6.24 {Tcl_GetsObj: crlf mode: lone \r} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "\r"
chan close $f
set f [open $path(test1)]
chan configure $f -translation crlf
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list 1 "\r" -1 ""]
-test chan-io-6.25 {Tcl_GetsObj: crlf mode: \r\r} {
+} -result [list 1 "\r" -1 ""]
+test chan-io-6.25 {Tcl_GetsObj: crlf mode: \r\r} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "\r\r"
chan close $f
set f [open $path(test1)]
chan configure $f -translation crlf
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list 2 "\r\r" -1 ""]
-test chan-io-6.26 {Tcl_GetsObj: crlf mode: \r\n} {
+} -result [list 2 "\r\r" -1 ""]
+test chan-io-6.26 {Tcl_GetsObj: crlf mode: \r\n} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "\r\n"
chan close $f
set f [open $path(test1)]
chan configure $f -translation crlf
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list 0 "" -1 ""]
-test chan-io-6.27 {Tcl_GetsObj: crlf mode: 1 char} {
+} -result {0 {} -1 {}}
+test chan-io-6.27 {Tcl_GetsObj: crlf mode: 1 char} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f a
chan close $f
set f [open $path(test1)]
chan configure $f -translation crlf
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} {1 a -1 {}}
-test chan-io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} {
+} -result {1 a -1 {}}
+test chan-io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "a\r\n"
chan close $f
set f [open $path(test1)]
chan configure $f -translation crlf
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} {1 a -1 {}}
-test chan-io-6.29 {Tcl_GetsObj: crlf mode: several chars} {
+} -result {1 a -1 {}}
+test chan-io-6.29 {Tcl_GetsObj: crlf mode: several chars} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
chan close $f
set f [open $path(test1)]
chan configure $f -translation crlf
- set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""]
-test chan-io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} {
+} -result [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""]
+test chan-io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} -constraints {testchannel} -body {
# if (eol >= dstEnd)
set f [open $path(test1) w]
chan configure $f -translation lf
@@ -693,23 +699,26 @@ test chan-io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} {
chan close $f
set f [open $path(test1)]
chan configure $f -translation crlf -buffersize 16
- set x [list [chan gets $f line] $line [testchannel inputbuffered $f]]
+ list [chan gets $f line] $line [testchannel inputbuffered $f]
+} -cleanup {
chan close $f
- set x
-} [list 15 "123456789012345" 15]
-test chan-io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel openpipe fileevent} {
+} -result [list 15 "123456789012345" 15]
+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
- set x [chan gets $f]
+ lappend x [chan gets $f]
chan configure $f -blocking 0
- lappend x [chan gets $f line] $line [chan blocked $f] [testchannel inputbuffered $f]
+ lappend x [chan gets $f line] $line [chan blocked $f] \
+ [testchannel inputbuffered $f]
+} -cleanup {
chan close $f
- set x
-} [list "bbbbbbbbbbbbbb" -1 "" 1 16]
-test chan-io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} {
+} -result {bbbbbbbbbbbbbb -1 {} 1 16}
+test chan-io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} -constraints {testchannel} -body {
# not (FilterInputBytes() != 0)
set f [open $path(test1) w]
chan configure $f -translation lf
@@ -717,11 +726,11 @@ test chan-io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testcha
chan close $f
set f [open $path(test1)]
chan configure $f -translation crlf -buffersize 16
- set x [list [chan gets $f line] $line [chan tell $f] [testchannel inputbuffered $f]]
+ list [chan gets $f line] $line [chan tell $f] [testchannel inputbuffered $f]
+} -cleanup {
chan close $f
- set x
-} [list 15 "123456789012345" 17 3]
-test chan-io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} {
+} -result {15 123456789012345 17 3}
+test chan-io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} -body {
# eol still equals dstEnd
set f [open $path(test1) w]
chan configure $f -translation lf
@@ -729,11 +738,11 @@ test chan-io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} {
chan close $f
set f [open $path(test1)]
chan configure $f -translation crlf -buffersize 16
- set x [list [chan gets $f line] $line [chan eof $f]]
+ list [chan gets $f line] $line [chan eof $f]
+} -cleanup {
chan close $f
- set x
-} [list 16 "123456789012345\r" 1]
-test chan-io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} {
+} -result [list 16 "123456789012345\r" 1]
+test chan-io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} -body {
# not (*eol == '\n')
set f [open $path(test1) w]
chan configure $f -translation lf
@@ -741,161 +750,171 @@ test chan-io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n}
chan close $f
set f [open $path(test1)]
chan configure $f -translation crlf -buffersize 16
- set x [list [chan gets $f line] $line [chan tell $f]]
+ list [chan gets $f line] $line [chan tell $f]
+} -cleanup {
chan close $f
- set x
-} [list 20 "123456789012345\rabcd" 22]
-test chan-io-6.35 {Tcl_GetsObj: auto mode: no chars} {
+} -result [list 20 "123456789012345\rabcd" 22]
+test chan-io-6.35 {Tcl_GetsObj: auto mode: no chars} -body {
set f [open $path(test1) w]
chan close $f
set f [open $path(test1)]
chan configure $f -translation auto
- set x [list [chan gets $f line] $line]
+ list [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} {-1 {}}
-test chan-io-6.36 {Tcl_GetsObj: auto mode: lone \n} {
+} -result {-1 {}}
+test chan-io-6.36 {Tcl_GetsObj: auto mode: lone \n} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "\n"
chan close $f
set f [open $path(test1)]
chan configure $f -translation auto
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list 0 "" -1 ""]
-test chan-io-6.37 {Tcl_GetsObj: auto mode: lone \r} {
+} -result {0 {} -1 {}}
+test chan-io-6.37 {Tcl_GetsObj: auto mode: lone \r} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "\r"
chan close $f
set f [open $path(test1)]
chan configure $f -translation auto
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list 0 "" -1 ""]
-test chan-io-6.38 {Tcl_GetsObj: auto mode: \r\r} {
+} -result {0 {} -1 {}}
+test chan-io-6.38 {Tcl_GetsObj: auto mode: \r\r} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "\r\r"
chan close $f
set f [open $path(test1)]
chan configure $f -translation auto
- set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list 0 "" 0 "" -1 ""]
-test chan-io-6.39 {Tcl_GetsObj: auto mode: \r\n} {
+} -result {0 {} 0 {} -1 {}}
+test chan-io-6.39 {Tcl_GetsObj: auto mode: \r\n} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "\r\n"
chan close $f
set f [open $path(test1)]
chan configure $f -translation auto
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list 0 "" -1 ""]
-test chan-io-6.40 {Tcl_GetsObj: auto mode: 1 char} {
+} -result {0 {} -1 {}}
+test chan-io-6.40 {Tcl_GetsObj: auto mode: 1 char} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f a
chan close $f
set f [open $path(test1)]
chan configure $f -translation auto
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} {1 a -1 {}}
-test chan-io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} {
+} -result {1 a -1 {}}
+test chan-io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "a\r\n"
chan close $f
set f [open $path(test1)]
chan configure $f -translation auto
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} {1 a -1 {}}
-test chan-io-6.42 {Tcl_GetsObj: auto mode: several chars} {
+} -result {1 a -1 {}}
+test chan-io-6.42 {Tcl_GetsObj: auto mode: several chars} -setup {
+ set x ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
chan close $f
set f [open $path(test1)]
chan configure $f -translation auto
- set x [list [chan gets $f line] $line [chan gets $f line] $line]
+ lappend x [chan gets $f line] $line [chan gets $f line] $line
lappend x [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""]
-test chan-io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} {
+} -result {4 abcd 4 efgh 4 ijkl 4 mnop -1 {}}
+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
- set x [list [chan gets $f]]
+ lappend x [chan gets $f]
chan configure $f -blocking 0
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
chan configure $f -blocking 1
chan puts -nonewline $f "\nabcd\refg\x1a"
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
lappend x [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
-test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe fileevent} {
+} -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg}
+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
- set x [list [chan gets $f]]
+ lappend x [chan gets $f]
chan configure $f -blocking 0
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
chan configure $f -blocking 1
chan puts -nonewline $f "abcd\refg\x1a"
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
lappend x [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
-test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel openpipe fileevent} {
+} -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg}
+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"
chan configure $f -buffersize 16
chan gets $f
chan configure $f -blocking 0
- set x [list [chan gets $f line] $line [testchannel queuedcr $f]]
+ lappend x [chan gets $f line] $line [testchannel queuedcr $f]
chan configure $f -blocking 1
chan puts -nonewline $f "\nabcd\refg"
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
+} -cleanup {
chan close $f
- set x
-} [list 15 "123456789abcdef" 1 4 "abcd" 0]
-test chan-io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel openpipe fileevent} {
+} -result {15 123456789abcdef 1 4 abcd 0}
+test chan-io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} -setup {
+ 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
chan gets $f
chan configure $f -blocking 0
- set x [list [chan gets $f line] $line [testchannel queuedcr $f]]
+ lappend x [chan gets $f line] $line [testchannel queuedcr $f]
chan configure $f -blocking 1
chan puts -nonewline $f "\n\x1a"
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
+} -cleanup {
chan close $f
- set x
-} [list 15 "123456789abcdef" 1 -1 "" 0]
-test chan-io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testchannel} {
+} -result {15 123456789abcdef 1 -1 {} 0}
+test chan-io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} -constraints {testchannel} -body {
# (eol == dstEnd)
set f [open $path(test1) w]
chan configure $f -translation lf
@@ -903,11 +922,11 @@ test chan-io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {te
chan close $f
set f [open $path(test1)]
chan configure $f -translation auto -buffersize 16
- set x [list [chan gets $f] [testchannel inputbuffered $f]]
+ list [chan gets $f] [testchannel inputbuffered $f]
+} -cleanup {
chan close $f
- set x
-} [list "123456789012345" 15]
-test chan-io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testchannel} {
+} -result {123456789012345 15}
+test chan-io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} -constraints {testchannel} -body {
# PeekAhead() did not get any, so (eol >= dstEnd)
set f [open $path(test1) w]
chan configure $f -translation lf
@@ -915,44 +934,44 @@ test chan-io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {
chan close $f
set f [open $path(test1)]
chan configure $f -translation auto -buffersize 16
- set x [list [chan gets $f] [testchannel queuedcr $f]]
+ list [chan gets $f] [testchannel queuedcr $f]
+} -cleanup {
chan close $f
- set x
-} [list "123456789012345" 1]
-test chan-io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} {
+} -result {123456789012345 1}
+test chan-io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} -constraints {testchannel} -body {
# if (*eol == '\n') {skip++}
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "123456\r\n78901"
chan close $f
set f [open $path(test1)]
- set x [list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f]]
+ list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f]
+} -cleanup {
chan close $f
- set x
-} [list "123456" 0 8 "78901"]
-test chan-io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} {
+} -result {123456 0 8 78901}
+test chan-io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} -constraints {testchannel} -body {
# not (*eol == '\n')
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "123456\r78901"
chan close $f
set f [open $path(test1)]
- set x [list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f]]
+ list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f]
+} -cleanup {
chan close $f
- set x
-} [list "123456" 0 7 "78901"]
-test chan-io-6.51 {Tcl_GetsObj: auto mode: \n} {
+} -result {123456 0 7 78901}
+test chan-io-6.51 {Tcl_GetsObj: auto mode: \n} -body {
# else if (*eol == '\n') {goto gotoeol;}
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "123456\n78901"
chan close $f
set f [open $path(test1)]
- set x [list [chan gets $f] [chan tell $f] [chan gets $f]]
+ list [chan gets $f] [chan tell $f] [chan gets $f]
+} -cleanup {
chan close $f
- set x
-} [list "123456" 7 "78901"]
-test chan-io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} {
+} -result {123456 7 78901}
+test chan-io-6.52 {Tcl_GetsObj: saw EOF character} -constraints {testchannel} -body {
# if (eof != NULL)
set f [open $path(test1) w]
chan configure $f -translation lf
@@ -960,30 +979,30 @@ test chan-io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} {
chan close $f
set f [open $path(test1)]
chan configure $f -eofchar \x1a
- set x [list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f]]
+ list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f]
+} -cleanup {
chan close $f
- set x
-} [list "123456" 0 6 ""]
-test chan-io-6.53 {Tcl_GetsObj: device EOF} {
+} -result {123456 0 6 {}}
+test chan-io-6.53 {Tcl_GetsObj: device EOF} -body {
# didn't produce any bytes
set f [open $path(test1) w]
chan close $f
set f [open $path(test1)]
- set x [list [chan gets $f line] $line [chan eof $f]]
+ list [chan gets $f line] $line [chan eof $f]
+} -cleanup {
chan close $f
- set x
-} {-1 {} 1}
-test chan-io-6.54 {Tcl_GetsObj: device EOF} {
+} -result {-1 {} 1}
+test chan-io-6.54 {Tcl_GetsObj: device EOF} -body {
# got some bytes before EOF.
set f [open $path(test1) w]
chan puts -nonewline $f abc
chan close $f
set f [open $path(test1)]
- set x [list [chan gets $f line] $line [chan eof $f]]
+ list [chan gets $f line] $line [chan eof $f]
+} -cleanup {
chan close $f
- set x
-} {3 abc 1}
-test chan-io-6.55 {Tcl_GetsObj: overconverted} {
+} -result {3 abc 1}
+test chan-io-6.55 {Tcl_GetsObj: overconverted} -body {
# Tcl_ExternalToUtf(), make sure state updated
set f [open $path(test1) w]
chan configure $f -encoding iso2022-jp
@@ -991,32 +1010,40 @@ test chan-io-6.55 {Tcl_GetsObj: overconverted} {
chan close $f
set f [open $path(test1)]
chan configure $f -encoding iso2022-jp
- set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line]
+ list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"]
-test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio openpipe fileevent} {
+} -result [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"]
+test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} -setup {
update
- set f [open "|[list [interpreter] $path(cat)]" w+]
+ variable x {}
+} -constraints {stdio openpipe fileevent} -body {
+ set f [openpipe w+ $path(cat)]
chan configure $f -buffering none
chan puts -nonewline $f "foobar"
chan configure $f -blocking 0
- variable x {}
- after 500 [namespace code { lappend x timeout }]
- chan event $f readable [namespace code { lappend x [chan gets $f] }]
+ after 500 [namespace code {
+ lappend x timeout
+ }]
+ chan event $f readable [namespace code {
+ lappend x [chan gets $f]
+ }]
vwait [namespace which -variable x]
vwait [namespace which -variable x]
chan configure $f -blocking 1
chan puts -nonewline $f "baz\n"
- after 500 [namespace code { lappend x timeout }]
+ after 500 [namespace code {
+ lappend x timeout
+ }]
chan configure $f -blocking 0
vwait [namespace which -variable x]
vwait [namespace which -variable x]
+ return $x
+} -cleanup {
chan close $f
- set x
-} {{} timeout foobarbaz timeout}
+} -result {{} timeout foobarbaz timeout}
-test chan-io-7.1 {FilterInputBytes: split up character at end of buffer} {
+test chan-io-7.1 {FilterInputBytes: split up character at end of buffer} -body {
# (result == TCL_CONVERT_MULTIBYTE)
set f [open $path(test1) w]
chan configure $f -encoding shiftjis
@@ -1024,11 +1051,11 @@ test chan-io-7.1 {FilterInputBytes: split up character at end of buffer} {
chan close $f
set f [open $path(test1)]
chan configure $f -encoding shiftjis -buffersize 16
- set x [chan gets $f]
+ chan gets $f
+} -cleanup {
chan close $f
- set x
-} "1234567890123\uff10\uff11\uff12\uff13\uff14"
-test chan-io-7.2 {FilterInputBytes: split up character in middle of buffer} {
+} -result "1234567890123\uff10\uff11\uff12\uff13\uff14"
+test chan-io-7.2 {FilterInputBytes: split up character in middle of buffer} -body {
# (bufPtr->nextAdded < bufPtr->bufLength)
set f [open $path(test1) w]
chan configure $f -encoding binary
@@ -1036,44 +1063,46 @@ test chan-io-7.2 {FilterInputBytes: split up character in middle of buffer} {
chan close $f
set f [open $path(test1)]
chan configure $f -encoding shiftjis
- set x [list [chan gets $f line] $line [chan eof $f]]
+ list [chan gets $f line] $line [chan eof $f]
+} -cleanup {
chan close $f
- set x
-} [list 10 "1234567890" 0]
-test chan-io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} {
+} -result {10 1234567890 0}
+test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup {
+ set x ""
+} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -encoding binary
chan puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82"
chan close $f
set f [open $path(test1)]
chan configure $f -encoding shiftjis
- set x [list [chan gets $f line] $line]
+ lappend x [chan gets $f line] $line
lappend x [chan tell $f] [testchannel inputbuffered $f] [chan eof $f]
lappend x [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""]
-test chan-io-7.4 {FilterInputBytes: recover from split up character} {stdio openpipe fileevent} {
- set f [open "|[list [interpreter] $path(cat)]" w+]
+} -result [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""]
+test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup {
+ variable x ""
+} -constraints {stdio openpipe fileevent} -body {
+ 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
- chan event $f read [namespace code "ready $f"]
- variable x {}
- proc ready {f} {
- variable x
+ chan event $f read [namespace code {
lappend x [chan gets $f line] $line [chan blocked $f]
- }
+ }]
vwait [namespace which -variable x]
chan configure $f -encoding binary -blocking 1
chan puts $f "\x51\x82\x52"
chan configure $f -encoding shiftjis
vwait [namespace which -variable x]
+ return $x
+} -cleanup {
chan close $f
- set x
-} [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0]
+} -result [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0]
-test chan-io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} {
+test chan-io-8.1 {PeekAhead: only go to device if no more cached data} -constraints {testchannel} -body {
# (bufPtr->nextPtr == NULL)
set f [open $path(test1) w]
chan configure $f -encoding ascii -translation lf
@@ -1083,43 +1112,43 @@ test chan-io-8.1 {PeekAhead: only go to device if no more cached data} {testchan
chan configure $f -encoding ascii -translation auto -buffersize 16
# here
chan gets $f
- set x [testchannel inputbuffered $f]
+ testchannel inputbuffered $f
+} -cleanup {
chan close $f
- set x
-} "7"
-test chan-io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel openpipe fileevent} {
+} -result 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"
- variable x {}
- chan event $f read [namespace code "ready $f"]
- proc ready {f} {
- variable x
+ chan event $f read [namespace code {
lappend x [chan gets $f line] $line [testchannel inputbuffered $f]
- }
+ }]
chan configure $f -encoding unicode -buffersize 16 -blocking 0
vwait [namespace which -variable x]
chan configure $f -translation auto -encoding ascii -blocking 1
# here
vwait [namespace which -variable x]
+ return $x
+} -cleanup {
chan close $f
- set x
-} [list -1 "" 42 15 "123456789012345" 25]
-test chan-io-8.3 {PeekAhead: no cached data available} {stdio testchannel openpipe fileevent} {
+} -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
- set x [list [chan gets $f line] $line [testchannel queuedcr $f]]
+ list [chan gets $f line] $line [testchannel queuedcr $f]
+} -cleanup {
chan close $f
- set x
-} [list 15 "abcdefghijklmno" 1]
+} -result {15 abcdefghijklmno 1}
set a "123456789012345678901234567890"
append a "123456789012345678901234567890"
append a "1234567890123456789012345678901"
-test chan-io-8.4 {PeekAhead: cached data available in this buffer} {
+test chan-io-8.4 {PeekAhead: cached data available in this buffer} -body {
# not (bytesLeft == 0)
set f [open $path(test1) w+]
chan configure $f -translation binary
@@ -1130,45 +1159,47 @@ test chan-io-8.4 {PeekAhead: cached data available in this buffer} {
# "${a}\r" was converted in one operation (because ENCODING_LINESIZE is
# 30). To check if "\n" follows, calls PeekAhead and determines that
# cached data is available in buffer w/o having to call driver.
- set x [chan gets $f]
+ chan gets $f
+} -cleanup {
chan close $f
- set x
-} $a
+} -result $a
unset a
-test chan-io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe fileevent} {
+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
# here
- set x [list [chan gets $f line] $line [testchannel queuedcr $f]]
+ list [chan gets $f line] $line [testchannel queuedcr $f]
+} -cleanup {
chan close $f
- set x
-} {15 abcdefghijklmno 1}
-test chan-io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe fileevent} {
+} -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
# here
- set x [list [chan gets $f line] $line [testchannel queuedcr $f]]
+ list [chan gets $f line] $line [testchannel queuedcr $f]
+} -cleanup {
chan close $f
- set x
-} {15 abcdefghijklmno 1}
-test chan-io-8.7 {PeekAhead: cleanup} {stdio testchannel openpipe fileevent} {
+} -result {15 abcdefghijklmno 1}
+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
- set x [list [chan gets $f line] $line [testchannel queuedcr $f]]
+ lappend x [chan gets $f line] $line [testchannel queuedcr $f]
chan puts -nonewline $f "\x1a"
lappend x [chan gets $f line] $line
+} -cleanup {
chan close $f
- set x
-} {15 abcdefghijklmno 1 -1 {}}
+} -result {15 abcdefghijklmno 1 -1 {}}
test chan-io-9.1 {CommonGetsCleanup} emptyTest {
} {}
@@ -1176,18 +1207,18 @@ test chan-io-9.1 {CommonGetsCleanup} emptyTest {
test chan-io-10.1 {Tcl_ReadChars: CheckChannelErrors} emptyTest {
# no test, need to cause an async error.
} {}
-test chan-io-10.2 {Tcl_ReadChars: loop until enough copied} {
+test chan-io-10.2 {Tcl_ReadChars: loop until enough copied} -body {
# one time
# for (copied = 0; (unsigned) toRead > 0; )
set f [open $path(test1) w]
chan puts $f abcdefghijklmnop
chan close $f
set f [open $path(test1)]
- set x [chan read $f 5]
+ chan read $f 5
+} -cleanup {
chan close $f
- set x
-} {abcde}
-test chan-io-10.3 {Tcl_ReadChars: loop until enough copied} {
+} -result {abcde}
+test chan-io-10.3 {Tcl_ReadChars: loop until enough copied} -body {
# multiple times
# for (copied = 0; (unsigned) toRead > 0; )
set f [open $path(test1) w]
@@ -1196,34 +1227,34 @@ test chan-io-10.3 {Tcl_ReadChars: loop until enough copied} {
set f [open $path(test1)]
chan configure $f -buffersize 16
# here
- set x [chan read $f 19]
+ chan read $f 19
+} -cleanup {
chan close $f
- set x
-} {abcdefghijklmnopqrs}
-test chan-io-10.4 {Tcl_ReadChars: no more in channel buffer} {
+} -result {abcdefghijklmnopqrs}
+test chan-io-10.4 {Tcl_ReadChars: no more in channel buffer} -body {
# (copiedNow < 0)
set f [open $path(test1) w]
chan puts -nonewline $f abcdefghijkl
chan close $f
set f [open $path(test1)]
# here
- set x [chan read $f 1000]
+ chan read $f 1000
+} -cleanup {
chan close $f
- set x
-} {abcdefghijkl}
-test chan-io-10.5 {Tcl_ReadChars: stop on EOF} {
+} -result {abcdefghijkl}
+test chan-io-10.5 {Tcl_ReadChars: stop on EOF} -body {
# (chanPtr->flags & CHANNEL_EOF)
set f [open $path(test1) w]
chan puts -nonewline $f abcdefghijkl
chan close $f
set f [open $path(test1)]
# here
- set x [chan read $f 1000]
+ chan read $f 1000
+} -cleanup {
chan close $f
- set x
-} {abcdefghijkl}
+} -result {abcdefghijkl}
-test chan-io-11.1 {ReadBytes: want to read a lot} {
+test chan-io-11.1 {ReadBytes: want to read a lot} -body {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
chan puts -nonewline $f abcdefghijkl
@@ -1231,11 +1262,11 @@ test chan-io-11.1 {ReadBytes: want to read a lot} {
set f [open $path(test1)]
chan configure $f -encoding binary
# here
- set x [chan read $f 1000]
+ chan read $f 1000
+} -cleanup {
chan close $f
- set x
-} {abcdefghijkl}
-test chan-io-11.2 {ReadBytes: want to read all} {
+} -result {abcdefghijkl}
+test chan-io-11.2 {ReadBytes: want to read all} -body {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
chan puts -nonewline $f abcdefghijkl
@@ -1243,11 +1274,11 @@ test chan-io-11.2 {ReadBytes: want to read all} {
set f [open $path(test1)]
chan configure $f -encoding binary
# here
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} {abcdefghijkl}
-test chan-io-11.3 {ReadBytes: allocate more space} {
+} -result {abcdefghijkl}
+test chan-io-11.3 {ReadBytes: allocate more space} -body {
# (toRead > length - offset - 1)
set f [open $path(test1) w]
chan puts -nonewline $f abcdefghijklmnopqrstuvwxyz
@@ -1255,11 +1286,11 @@ test chan-io-11.3 {ReadBytes: allocate more space} {
set f [open $path(test1)]
chan configure $f -buffersize 16 -encoding binary
# here
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} {abcdefghijklmnopqrstuvwxyz}
-test chan-io-11.4 {ReadBytes: EOF char found} {
+} -result {abcdefghijklmnopqrstuvwxyz}
+test chan-io-11.4 {ReadBytes: EOF char found} -body {
# (TranslateInputEOL() != 0)
set f [open $path(test1) w]
chan puts $f abcdefghijklmnopqrstuvwxyz
@@ -1267,34 +1298,34 @@ test chan-io-11.4 {ReadBytes: EOF char found} {
set f [open $path(test1)]
chan configure $f -eofchar m -encoding binary
# here
- set x [list [chan read $f] [chan eof $f] [chan read $f] [chan eof $f]]
+ list [chan read $f] [chan eof $f] [chan read $f] [chan eof $f]
+} -cleanup {
chan close $f
- set x
-} [list "abcdefghijkl" 1 "" 1]
+} -result {abcdefghijkl 1 {} 1}
-test chan-io-12.1 {ReadChars: want to read a lot} {
+test chan-io-12.1 {ReadChars: want to read a lot} -body {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
chan puts -nonewline $f abcdefghijkl
chan close $f
set f [open $path(test1)]
# here
- set x [chan read $f 1000]
+ chan read $f 1000
+} -cleanup {
chan close $f
- set x
-} {abcdefghijkl}
-test chan-io-12.2 {ReadChars: want to read all} {
+} -result {abcdefghijkl}
+test chan-io-12.2 {ReadChars: want to read all} -body {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
chan puts -nonewline $f abcdefghijkl
chan close $f
set f [open $path(test1)]
# here
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} {abcdefghijkl}
-test chan-io-12.3 {ReadChars: allocate more space} {
+} -result {abcdefghijkl}
+test chan-io-12.3 {ReadChars: allocate more space} -body {
# (toRead > length - offset - 1)
set f [open $path(test1) w]
chan puts -nonewline $f abcdefghijklmnopqrstuvwxyz
@@ -1302,22 +1333,21 @@ test chan-io-12.3 {ReadChars: allocate more space} {
set f [open $path(test1)]
chan configure $f -buffersize 16
# here
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} {abcdefghijklmnopqrstuvwxyz}
-test chan-io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} {
+} -result {abcdefghijklmnopqrstuvwxyz}
+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
- chan event $f read [namespace code "ready $f"]
- proc ready {f} {
- variable x
+ chan event $f read [namespace code {
lappend x [chan read $f] [testchannel inputbuffered $f]
- }
- variable x {}
+ }]
chan configure $f -encoding shiftjis
vwait [namespace which -variable x]
chan configure $f -encoding binary -blocking 1
@@ -1325,17 +1355,20 @@ test chan-io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileeve
after 500 ;# Give the cat process time to catch up
chan configure $f -encoding shiftjis -blocking 0
vwait [namespace which -variable x]
+ return $x
+} -cleanup {
chan close $f
- set x
-} [list "123456789012345" 1 "\u672c" 0]
-test chan-io-12.5 {ReadChars: chan events on partial characters} {stdio openpipe fileevent} {
+} -result [list "123456789012345" 1 "\u672c" 0]
+test chan-io-12.5 {ReadChars: chan events on partial characters} -setup {
+ variable x {}
+} -constraints {stdio openpipe fileevent} -body {
set path(test1) [makeFile {
chan configure stdout -encoding binary -buffering none
chan gets stdin; chan puts -nonewline "\xe7"
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]} {
@@ -1345,7 +1378,6 @@ test chan-io-12.5 {ReadChars: chan events on partial characters} {stdio openpipe
chan puts $f "go1"
chan flush $f
chan configure $f -blocking 0 -encoding utf-8
- variable x {}
vwait [namespace which -variable x]
after 500 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
@@ -1359,32 +1391,31 @@ test chan-io-12.5 {ReadChars: chan events on partial characters} {stdio openpipe
vwait [namespace which -variable x]
vwait [namespace which -variable x]
lappend x [catch {chan close $f} msg] $msg
- set x
-} "{} timeout {} timeout \u7266 {} eof 0 {}"
+} -result "{} timeout {} timeout \u7266 {} eof 0 {}"
-test chan-io-13.1 {TranslateInputEOL: cr mode} {} {
+test chan-io-13.1 {TranslateInputEOL: cr mode} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "abcd\rdef\r"
chan close $f
set f [open $path(test1)]
chan configure $f -translation cr
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "abcd\ndef\n"
-test chan-io-13.2 {TranslateInputEOL: crlf mode} {
+} -result "abcd\ndef\n"
+test chan-io-13.2 {TranslateInputEOL: crlf mode} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "abcd\r\ndef\r\n"
chan close $f
set f [open $path(test1)]
chan configure $f -translation crlf
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "abcd\ndef\n"
-test chan-io-13.3 {TranslateInputEOL: crlf mode: naked cr} {
+} -result "abcd\ndef\n"
+test chan-io-13.3 {TranslateInputEOL: crlf mode: naked cr} -body {
# (src >= srcMax)
set f [open $path(test1) w]
chan configure $f -translation lf
@@ -1392,11 +1423,11 @@ test chan-io-13.3 {TranslateInputEOL: crlf mode: naked cr} {
chan close $f
set f [open $path(test1)]
chan configure $f -translation crlf
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "abcd\ndef\r"
-test chan-io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} {
+} -result "abcd\ndef\r"
+test chan-io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} -body {
# (src >= srcMax)
set f [open $path(test1) w]
chan configure $f -translation lf
@@ -1404,11 +1435,11 @@ test chan-io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} {
chan close $f
set f [open $path(test1)]
chan configure $f -translation crlf
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "abcd\ndef\rfgh"
-test chan-io-13.5 {TranslateInputEOL: crlf mode: naked lf} {
+} -result "abcd\ndef\rfgh"
+test chan-io-13.5 {TranslateInputEOL: crlf mode: naked lf} -body {
# (src >= srcMax)
set f [open $path(test1) w]
chan configure $f -translation lf
@@ -1416,32 +1447,32 @@ test chan-io-13.5 {TranslateInputEOL: crlf mode: naked lf} {
chan close $f
set f [open $path(test1)]
chan configure $f -translation crlf
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "abcd\ndef\nfgh"
-test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel openpipe fileevent} {
+} -result "abcd\ndef\nfgh"
+test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} -setup {
+ variable x {}
+ variable y {}
+} -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 "ready $f"]
- proc ready {f} {
- variable x
+ chan event $f read [namespace code {
lappend x [chan read $f] [testchannel queuedcr $f]
- }
- variable x {}
- variable y {}
+ }]
chan puts -nonewline $f "abcdefghj\r"
after 500 [namespace code {set y ok}]
vwait [namespace which -variable y]
chan puts -nonewline $f "\n01234"
after 500 [namespace code {set y ok}]
vwait [namespace which -variable y]
+ return $x
+} -cleanup {
chan close $f
- set x
-} [list "abcdefghj\n" 1 "01234" 0]
-test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel openpipe} {
+} -result [list "abcdefghj\n" 1 "01234" 0]
+test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} -constraints {testchannel openpipe} -body {
# (src >= srcMax)
set f [open $path(test1) w]
chan configure $f -translation lf
@@ -1449,11 +1480,11 @@ test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel openpipe
chan close $f
set f [open $path(test1)]
chan configure $f -translation auto
- set x [list [chan read $f] [testchannel queuedcr $f]]
+ list [chan read $f] [testchannel queuedcr $f]
+} -cleanup {
chan close $f
- set x
-} [list "abcd\n" 1]
-test chan-io-13.8 {TranslateInputEOL: auto mode: \r\n} {
+} -result [list "abcd\n" 1]
+test chan-io-13.8 {TranslateInputEOL: auto mode: \r\n} -body {
# (*src == '\n')
set f [open $path(test1) w]
chan configure $f -translation lf
@@ -1461,22 +1492,22 @@ test chan-io-13.8 {TranslateInputEOL: auto mode: \r\n} {
chan close $f
set f [open $path(test1)]
chan configure $f -translation auto
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "abcd\ndef"
-test chan-io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} {
+} -result "abcd\ndef"
+test chan-io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "abcd\rdef"
chan close $f
set f [open $path(test1)]
chan configure $f -translation auto
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "abcd\ndef"
-test chan-io-13.10 {TranslateInputEOL: auto mode: \n} {
+} -result "abcd\ndef"
+test chan-io-13.10 {TranslateInputEOL: auto mode: \n} -body {
# not (*src == '\r')
set f [open $path(test1) w]
chan configure $f -translation lf
@@ -1484,11 +1515,11 @@ test chan-io-13.10 {TranslateInputEOL: auto mode: \n} {
chan close $f
set f [open $path(test1)]
chan configure $f -translation auto
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "abcd\ndef"
-test chan-io-13.11 {TranslateInputEOL: EOF char} {
+} -result "abcd\ndef"
+test chan-io-13.11 {TranslateInputEOL: EOF char} -body {
# (*chanPtr->inEofChar != '\0')
set f [open $path(test1) w]
chan configure $f -translation lf
@@ -1496,11 +1527,11 @@ test chan-io-13.11 {TranslateInputEOL: EOF char} {
chan close $f
set f [open $path(test1)]
chan configure $f -translation auto -eofchar e
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "abcd\nd"
-test chan-io-13.12 {TranslateInputEOL: find EOF char in src} {
+} -result "abcd\nd"
+test chan-io-13.12 {TranslateInputEOL: find EOF char in src} -body {
# (*chanPtr->inEofChar != '\0')
set f [open $path(test1) w]
chan configure $f -translation lf
@@ -1508,16 +1539,16 @@ test chan-io-13.12 {TranslateInputEOL: find EOF char in src} {
chan close $f
set f [open $path(test1)]
chan configure $f -translation auto -eofchar e
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "\n\n\nab\n\nd"
+} -result "\n\n\nab\n\nd"
# Test standard handle management. The functions tested are Tcl_SetStdChannel
# and Tcl_GetStdChannel. Incidentally we are also testing channel table
# management.
-if {[info commands testchannel] ne ""} {
+if {[testConstraint testchannel]} {
set consoleFileNames [lsort [testchannel open]]
} else {
# just to avoid an error
@@ -1525,24 +1556,24 @@ if {[info commands testchannel] ne ""} {
}
test chan-io-14.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} {testchannel} {
- set l ""
- lappend l [chan configure stdin -buffering]
- lappend l [chan configure stdout -buffering]
- lappend l [chan configure stderr -buffering]
- lappend l [lsort [testchannel open]]
- set l
+ set result ""
+ lappend result [chan configure stdin -buffering]
+ lappend result [chan configure stdout -buffering]
+ lappend result [chan configure stderr -buffering]
+ lappend result [lsort [testchannel open]]
} [list line line none $consoleFileNames]
-test chan-io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} {
+test chan-io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} -setup {
interp create x
- set l ""
- lappend l [x eval {chan configure stdin -buffering}]
- lappend l [x eval {chan configure stdout -buffering}]
- lappend l [x eval {chan configure stderr -buffering}]
+ set result ""
+} -body {
+ lappend result [x eval {chan configure stdin -buffering}]
+ lappend result [x eval {chan configure stdout -buffering}]
+ lappend result [x eval {chan configure stderr -buffering}]
+} -cleanup {
interp delete x
- set l
-} {line line none}
+} -result {line line none}
set path(test3) [makeFile {} test3]
-test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec openpipe} {
+test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints {exec openpipe} -body {
set f [open $path(test1) w]
chan puts -nonewline $f {
chan close stdin
@@ -1564,15 +1595,15 @@ test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec openpipe} {
set f [open $path(test2) r]
set f2 [open $path(test3) r]
lappend result [chan read $f] [chan read $f2]
+} -cleanup {
chan close $f
chan close $f2
- set result
-} {{
+} -result {{
out
} {err
}}
# This test relies on the fact that stdout is used before stderr.
-test chan-io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec} {
+test chan-io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints {exec} -body {
set f [open $path(test1) w]
chan puts -nonewline $f { chan close stdin
chan close stdout
@@ -1581,7 +1612,8 @@ test chan-io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec} {
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
@@ -1593,10 +1625,10 @@ test chan-io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec} {
set f [open $path(test2) r]
set f2 [open $path(test3) r]
lappend result [chan read $f] [chan read $f2]
+} -cleanup {
chan close $f
chan close $f2
- set result
-} {{ chan close stdin
+} -result {{ chan close stdin
stdout
} {stderr
}}
@@ -1653,10 +1685,10 @@ 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 c [chan gets $f]
+ set f [openpipe r $path(script)]
+ chan gets $f
+} -cleanup {
chan close $f
- set c
} -result hello
test chan-io-14.9 {reuse of stdio special channels} -setup {
file delete $path(script)
@@ -1673,15 +1705,14 @@ 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 c [chan gets $f]
- chan close $f
- set c
+ set f [openpipe r $path(script) [array get path]]
+ chan gets $f
} -cleanup {
+ chan close $f
# Added delay to give Windows time to stop the spawned process and clean
# up its grip on the file test1. Added delete as proper test cleanup.
# The failing tests were 18.1 and 18.2 as first re-users of file "test1".
- after 10000
+ after [expr {[testConstraint win] ? 10000 : 500}]
file delete $path(script)
file delete $path(test1)
} -result hello
@@ -1699,39 +1730,42 @@ test chan-io-16.1 {Tcl_DeleteChan CloseHandler} emptyTest {
# These functions use "eof stdin" to ensure that the standard channels are
# added to the channel table of the interpreter.
-test chan-io-17.1 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} {
+test chan-io-17.1 {GetChannelTable, DeleteChannelTable on std handles} -setup {
+ set l ""
+} -constraints {testchannel} -body {
set l1 [testchannel refcount stdin]
chan eof stdin
interp create x
- set l ""
- lappend l [expr [testchannel refcount stdin] - $l1]
+ lappend l [expr {[testchannel refcount stdin] - $l1}]
x eval {chan eof stdin}
- lappend l [expr [testchannel refcount stdin] - $l1]
+ lappend l [expr {[testchannel refcount stdin] - $l1}]
interp delete x
- lappend l [expr [testchannel refcount stdin] - $l1]
-} {0 1 0}
-test chan-io-17.2 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} {
+ lappend l [expr {[testchannel refcount stdin] - $l1}]
+} -result {0 1 0}
+test chan-io-17.2 {GetChannelTable, DeleteChannelTable on std handles} -setup {
+ set l ""
+} -constraints {testchannel} -body {
set l1 [testchannel refcount stdout]
chan eof stdin
interp create x
- set l ""
- lappend l [expr [testchannel refcount stdout] - $l1]
+ lappend l [expr {[testchannel refcount stdout] - $l1}]
x eval {chan eof stdout}
- lappend l [expr [testchannel refcount stdout] - $l1]
+ lappend l [expr {[testchannel refcount stdout] - $l1}]
interp delete x
- lappend l [expr [testchannel refcount stdout] - $l1]
-} {0 1 0}
-test chan-io-17.3 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} {
+ lappend l [expr {[testchannel refcount stdout] - $l1}]
+} -result {0 1 0}
+test chan-io-17.3 {GetChannelTable, DeleteChannelTable on std handles} -setup {
+ set l ""
+} -constraints {testchannel} -body {
set l1 [testchannel refcount stderr]
chan eof stdin
interp create x
- set l ""
- lappend l [expr [testchannel refcount stderr] - $l1]
+ lappend l [expr {[testchannel refcount stderr] - $l1}]
x eval {chan eof stderr}
- lappend l [expr [testchannel refcount stderr] - $l1]
+ lappend l [expr {[testchannel refcount stderr] - $l1}]
interp delete x
- lappend l [expr [testchannel refcount stderr] - $l1]
-} {0 1 0}
+ lappend l [expr {[testchannel refcount stderr] - $l1}]
+} -result {0 1 0}
test chan-io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup {
file delete -force $path(test1)
@@ -1745,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)
@@ -1767,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)
@@ -1787,20 +1819,20 @@ 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} {
chan eof stdin
} 0
-test chan-io-19.2 {testing Tcl_GetChannel, user opened handle} {
+test chan-io-19.2 {testing Tcl_GetChannel, user opened handle} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
- set x [chan eof $f]
+ chan eof $f
+} -cleanup {
chan close $f
- set x
-} 0
+} -result 0
test chan-io-19.3 {Tcl_GetChannel, channel not found} -body {
chan eof file34
} -returnCodes error -result {can not find channel named "file34"}
@@ -1816,35 +1848,36 @@ 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} {
- set a [open $path(test2) w]
+test chan-io-20.1 {Tcl_CreateChannel: initial settings} -setup {
set old [encoding system]
+} -body {
+ set a [open $path(test2) w]
encoding system ascii
set f [open $path(test1) w]
- set x [chan configure $f -encoding]
- chan close $f
+ chan configure $f -encoding
+} -cleanup {
encoding system $old
+ chan close $f
chan close $a
- set x
-} {ascii}
-test chan-io-20.2 {Tcl_CreateChannel: initial settings} {win} {
+} -result {ascii}
+test chan-io-20.2 {Tcl_CreateChannel: initial settings} -constraints {win} -body {
set f [open $path(test1) w+]
- set x [list [chan configure $f -eofchar] [chan configure $f -translation]]
+ list [chan configure $f -eofchar] [chan configure $f -translation]
+} -cleanup {
chan close $f
- set x
-} [list [list \x1a ""] {auto crlf}]
-test chan-io-20.3 {Tcl_CreateChannel: initial settings} {unix} {
+} -result [list [list \x1a ""] {auto crlf}]
+test chan-io-20.3 {Tcl_CreateChannel: initial settings} -constraints {unix} -body {
set f [open $path(test1) w+]
- set x [list [chan configure $f -eofchar] [chan configure $f -translation]]
+ list [chan configure $f -eofchar] [chan configure $f -translation]
+} -cleanup {
chan close $f
- set x
-} {{{} {}} {auto lf}}
-set path(stdout) [makeFile {} stdout]
-test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio openpipe} {
+} -result {{{} {}} {auto lf}}
+test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup {
+ set path(stdout) [makeFile {} stdout]
+} -constraints {stdio openpipe} -body {
set f [open $path(script) w]
chan puts -nonewline $f {
chan close stdout
@@ -1855,10 +1888,11 @@ test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio open
chan puts stderr [chan configure stdout -buffersize]
}
chan close $f
- set f [open "|[list [interpreter] $path(script)]"]
- catch {chan close $f} msg
- set msg
-} {777}
+ set f [openpipe r $path(script)]
+ chan close $f
+} -cleanup {
+ removeFile $path(stdout)
+} -returnCodes error -result {777}
test chan-io-21.1 {Chan CloseChannelsOnExit} emptyTest {
} {}
@@ -1873,99 +1907,107 @@ test chan-io-22.1 {Tcl_GetChannelMode} emptyTest {
# Not used anywhere in Tcl.
} {}
-test chan-io-23.1 {Tcl_GetChannelName} {testchannel} {
+test chan-io-23.1 {Tcl_GetChannelName} -constraints {testchannel} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
set n [testchannel name $f]
+ expr {$n eq $f ? "ok" : "$n != $f"}
+} -cleanup {
chan close $f
- string compare $n $f
-} 0
+} -result ok
-test chan-io-24.1 {Tcl_GetChannelType} {testchannel} {
+test chan-io-24.1 {Tcl_GetChannelType} -constraints {testchannel} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
- set t [testchannel type $f]
+ testchannel type $f
+} -cleanup {
chan close $f
- string compare $t file
-} 0
+} -result "file"
-test chan-io-25.1 {Tcl_GetChannelHandle, input} {testchannel} {
+test chan-io-25.1 {Tcl_GetChannelHandle, input} -setup {
+ set l ""
+} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -eofchar {}
chan puts $f "1234567890\n098765432"
chan close $f
set f [open $path(test1) r]
chan gets $f
- set l ""
lappend l [testchannel inputbuffered $f]
lappend l [chan tell $f]
+} -cleanup {
chan close $f
- set l
-} {10 11}
-test chan-io-25.2 {Tcl_GetChannelHandle, output} {testchannel} {
+} -result {10 11}
+test chan-io-25.2 {Tcl_GetChannelHandle, output} -setup {
file delete $path(test1)
+ set l ""
+} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f hello
- set l ""
lappend l [testchannel outputbuffered $f]
lappend l [chan tell $f]
chan flush $f
lappend l [testchannel outputbuffered $f]
lappend l [chan tell $f]
+} -cleanup {
chan close $f
file delete $path(test1)
- set l
-} {6 6 0 6}
+} -result {6 6 0 6}
-test chan-io-26.1 {Tcl_GetChannelInstanceData} {stdio openpipe} {
+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]"]
- expr [pid $f]
+ set f [openpipe r << exit]
+ pid $f
+} -constraints {stdio openpipe} -cleanup {
chan close $f
-} {}
+} -match regexp -result {^\d+$}
# Test flushing. The functions tested here are FlushChannel.
-test chan-io-27.1 {FlushChannel, no output buffered} {
+test chan-io-27.1 {FlushChannel, no output buffered} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan flush $f
- set s [file size $path(test1)]
+ file size $path(test1)
+} -cleanup {
chan close $f
- set s
-} 0
-test chan-io-27.2 {FlushChannel, some output buffered} {
+} -result 0
+test chan-io-27.2 {FlushChannel, some output buffered} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -eofchar {}
- set l ""
chan puts $f hello
lappend l [file size $path(test1)]
chan flush $f
lappend l [file size $path(test1)]
chan close $f
lappend l [file size $path(test1)]
- set l
-} {0 6 6}
-test chan-io-27.3 {FlushChannel, implicit flush on chan close} {
+} -result {0 6 6}
+test chan-io-27.3 {FlushChannel, implicit flush on chan close} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -eofchar {}
- set l ""
chan puts $f hello
lappend l [file size $path(test1)]
chan close $f
lappend l [file size $path(test1)]
- set l
-} {0 6}
-test chan-io-27.4 {FlushChannel, implicit flush when buffer fills} {
+} -result {0 6}
+test chan-io-27.4 {FlushChannel, implicit flush when buffer fills} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -eofchar {}
chan configure $f -buffersize 60
- set l ""
lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
chan puts $f hello
@@ -1973,15 +2015,15 @@ test chan-io-27.4 {FlushChannel, implicit flush when buffer fills} {
lappend l [file size $path(test1)]
chan flush $f
lappend l [file size $path(test1)]
+} -cleanup {
chan close $f
- set l
-} {0 60 72}
-test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan close} \
- {unixOrPc} {
+} -result {0 60 72}
+test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan close} -setup {
file delete $path(test1)
+ set l ""
+} -constraints {unixOrPc} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffersize 60 -eofchar {}
- set l ""
lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
chan puts $f hello
@@ -1989,14 +2031,13 @@ test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan cl
lappend l [file size $path(test1)]
chan close $f
lappend l [file size $path(test1)]
- set l
-} {0 60 72}
+} -result {0 60 72}
set path(pipe) [makeFile {} pipe]
set path(output) [makeFile {} output]
-test chan-io-27.6 {FlushChannel, async flushing, async chan close} \
- {stdio asyncPipeChan Close openpipe} {
+test chan-io-27.6 {FlushChannel, async flushing, async chan close} -setup {
file delete $path(pipe)
file delete $path(output)
+} -constraints {stdio asyncPipeChan Close openpipe} -body {
set f [open $path(pipe) w]
chan puts $f "set f \[[list open $path(output) w]]"
chan puts $f {
@@ -2014,7 +2055,7 @@ test chan-io-27.6 {FlushChannel, async flushing, async chan close} \
}
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
@@ -2028,26 +2069,28 @@ test chan-io-27.6 {FlushChannel, async flushing, async chan close} \
} else {
set result ok
}
-} ok
+} -result ok
# Tests closing a channel. The functions tested are Chan CloseChannel and
# Tcl_Chan Close.
-test chan-io-28.1 {Chan CloseChannel called when all references are dropped} {testchannel} {
+test chan-io-28.1 {Chan CloseChannel called when all references are dropped} -setup {
file delete $path(test1)
+ set l ""
+} -constraints {testchannel} -body {
set f [open $path(test1) w]
interp create x
interp share "" $f x
- set l ""
lappend l [testchannel refcount $f]
x eval chan close $f
interp delete x
lappend l [testchannel refcount $f]
+} -cleanup {
chan close $f
- set l
-} {2 1}
-test chan-io-28.2 {Chan CloseChannel called when all references are dropped} {
+} -result {2 1}
+test chan-io-28.2 {Chan CloseChannel called when all references are dropped} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
interp create x
interp share "" $f x
@@ -2057,14 +2100,14 @@ test chan-io-28.2 {Chan CloseChannel called when all references are dropped} {
x eval chan close $f
interp delete x
set f [open $path(test1) r]
- set l [chan gets $f]
+ chan gets $f
+} -cleanup {
chan close $f
- set l
-} abcdef
-test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} \
- {stdio asyncPipeChan Close nonPortable openpipe} {
+} -result abcdef
+test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} -setup {
file delete $path(pipe)
file delete $path(output)
+} -constraints {stdio asyncPipeChan Close nonPortable openpipe} -body {
set f [open $path(pipe) w]
chan puts $f {
# Need to not have eof char appended on chan close, because the other
@@ -2087,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
@@ -2101,10 +2144,11 @@ test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} \
} else {
set result ok
}
-} ok
-test chan-io-28.4 {Tcl_Chan Close} {testchannel} {
+} -result ok
+test chan-io-28.4 {Tcl_Chan Close} -constraints {testchannel} -setup {
file delete $path(test1)
set l ""
+} -body {
lappend l [lsort [testchannel open]]
set f [open $path(test1) w]
lappend l [lsort [testchannel open]]
@@ -2113,8 +2157,8 @@ test chan-io-28.4 {Tcl_Chan Close} {testchannel} {
set x [list $consoleFileNames \
[lsort [list {*}$consoleFileNames $f]] \
$consoleFileNames]
- string compare $l $x
-} 0
+ expr {$l eq $x ? "ok" : "{$l} != {$x}"}
+} -result ok
test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup {
file delete $path(script)
} -constraints {stdio unix testchannel openpipe} -body {
@@ -2124,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
@@ -2132,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}}
@@ -2163,102 +2208,108 @@ 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}}
-test chan-io-29.1 {Tcl_WriteChars, channel not writable} {
- list [catch {chan puts stdin hello} msg] $msg
-} {1 {channel "stdin" wasn't opened for writing}}
-test chan-io-29.2 {Tcl_WriteChars, empty string} {
+test chan-io-29.1 {Tcl_WriteChars, channel not writable} -body {
+ chan puts stdin hello
+} -returnCodes error -result {channel "stdin" wasn't opened for writing}
+test chan-io-29.2 {Tcl_WriteChars, empty string} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -eofchar {}
chan puts -nonewline $f ""
chan close $f
file size $path(test1)
-} 0
-test chan-io-29.3 {Tcl_WriteChars, nonempty string} {
+} -result 0
+test chan-io-29.3 {Tcl_WriteChars, nonempty string} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -eofchar {}
chan puts -nonewline $f hello
chan close $f
file size $path(test1)
-} 5
-test chan-io-29.4 {Tcl_WriteChars, buffering in full buffering mode} {testchannel} {
+} -result 5
+test chan-io-29.4 {Tcl_WriteChars, buffering in full buffering mode} -setup {
file delete $path(test1)
+ set l ""
+} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffering full -eofchar {}
chan puts $f hello
- set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
chan flush $f
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
+} -cleanup {
chan close $f
- set l
-} {6 0 0 6}
-test chan-io-29.5 {Tcl_WriteChars, buffering in line buffering mode} {testchannel} {
+} -result {6 0 0 6}
+test chan-io-29.5 {Tcl_WriteChars, buffering in line buffering mode} -setup {
file delete $path(test1)
+ set l ""
+} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffering line -eofchar {}
chan puts -nonewline $f hello
- set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
chan puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
+} -cleanup {
chan close $f
- set l
-} {5 0 0 11}
-test chan-io-29.6 {Tcl_WriteChars, buffering in no buffering mode} {testchannel} {
+} -result {5 0 0 11}
+test chan-io-29.6 {Tcl_WriteChars, buffering in no buffering mode} -setup {
file delete $path(test1)
+ set l ""
+} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffering none -eofchar {}
chan puts -nonewline $f hello
- set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
chan puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
+} -cleanup {
chan close $f
- set l
-} {0 5 0 11}
-test chan-io-29.7 {Tcl_Flush, full buffering} {testchannel} {
+} -result {0 5 0 11}
+test chan-io-29.7 {Tcl_Flush, full buffering} -setup {
file delete $path(test1)
+ set l ""
+} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffering full -eofchar {}
chan puts -nonewline $f hello
- set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
chan puts $f hello
@@ -2267,15 +2318,16 @@ test chan-io-29.7 {Tcl_Flush, full buffering} {testchannel} {
chan flush $f
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
+} -cleanup {
chan close $f
- set l
-} {5 0 11 0 0 11}
-test chan-io-29.8 {Tcl_Flush, full buffering} {testchannel} {
+} -result {5 0 11 0 0 11}
+test chan-io-29.8 {Tcl_Flush, full buffering} -setup {
file delete $path(test1)
+ set l ""
+} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffering line
chan puts -nonewline $f hello
- set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
chan flush $f
@@ -2287,14 +2339,15 @@ test chan-io-29.8 {Tcl_Flush, full buffering} {testchannel} {
chan flush $f
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
+} -cleanup {
chan close $f
- set l
-} {5 0 0 5 0 11 0 11}
-test chan-io-29.9 {Tcl_Flush, channel not writable} {
- list [catch {chan flush stdin} msg] $msg
-} {1 {channel "stdin" wasn't opened for writing}}
-test chan-io-29.10 {Tcl_WriteChars, looping and buffering} {
+} -result {5 0 0 5 0 11 0 11}
+test chan-io-29.9 {Tcl_Flush, channel not writable} -body {
+ chan flush stdin
+} -returnCodes error -result {channel "stdin" wasn't opened for writing}
+test chan-io-29.10 {Tcl_WriteChars, looping and buffering} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf -eofchar {}
set f2 [open $path(longfile) r]
@@ -2304,9 +2357,10 @@ test chan-io-29.10 {Tcl_WriteChars, looping and buffering} {
chan close $f2
chan close $f1
file size $path(test1)
-} 387
-test chan-io-29.11 {Tcl_WriteChars, no newline, implicit flush} {
+} -result 387
+test chan-io-29.11 {Tcl_WriteChars, no newline, implicit flush} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
chan configure $f1 -eofchar {}
set f2 [open $path(longfile) r]
@@ -2316,10 +2370,11 @@ test chan-io-29.11 {Tcl_WriteChars, no newline, implicit flush} {
chan close $f1
chan close $f2
file size $path(test1)
-} 377
-test chan-io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} {
+} -result 377
+test chan-io-29.12 {Tcl_WriteChars on a pipe} -setup {
file delete $path(test1)
file delete $path(pipe)
+} -constraints {stdio openpipe} -body {
set f1 [open $path(pipe) w]
chan puts $f1 "set f1 \[[list open $path(longfile) r]]"
chan puts $f1 {
@@ -2328,23 +2383,25 @@ test chan-io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} {
}
}
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" != "$l2"} {
- set y broken
+ if {$l1 ne $l2} {
+ set y broken:$x
}
}
+ return $y
+} -cleanup {
chan close $f1
chan close $f2
- set y
-} ok
-test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio openpipe} {
+} -result ok
+test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} -setup {
file delete $path(test1)
file delete $path(pipe)
+} -constraints {stdio openpipe} -body {
set f1 [open $path(pipe) w]
chan puts $f1 {
chan puts [chan gets stdin]
@@ -2352,70 +2409,74 @@ test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio openpipe} {
}
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" != "$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" != "$backline"} {
- set y broken
+ if {$line ne $backline} {
+ set y broken2
}
+ return $y
+} -cleanup {
chan close $f1
chan close $f2
- set y
-} ok
-test chan-io-29.14 {Tcl_WriteChars, buffering and implicit flush at chan close} {
+} -result ok
+test chan-io-29.14 {Tcl_WriteChars, buffering and implicit flush at chan close} -setup {
file delete $path(test3)
+} -body {
set f [open $path(test3) w]
chan puts -nonewline $f "Text1"
chan puts -nonewline $f " Text 2"
chan puts $f " Text 3"
chan close $f
set f [open $path(test3) r]
- set x [chan gets $f]
+ chan gets $f
+} -cleanup {
chan close $f
- set x
-} {Text1 Text 2 Text 3}
-test chan-io-29.15 {Tcl_Flush, channel not open for writing} {
+} -result {Text1 Text 2 Text 3}
+test chan-io-29.15 {Tcl_Flush, channel not open for writing} -setup {
file delete $path(test1)
set fd [open $path(test1) w]
chan close $fd
+} -body {
set fd [open $path(test1) r]
- set x [list [catch {chan flush $fd} msg] $msg]
- chan close $fd
- string compare $x \
- [list 1 "channel \"$fd\" wasn't opened for writing"]
-} 0
-test chan-io-29.16 {Tcl_Flush on pipe opened only for reading} {stdio openpipe} {
- set fd [open "|[list [interpreter] cat longfile]" r]
- set x [list [catch {chan flush $fd} msg] $msg]
+ chan flush $fd
+} -returnCodes error -cleanup {
catch {chan close $fd}
- string compare $x \
- [list 1 "channel \"$fd\" wasn't opened for writing"]
-} 0
-test chan-io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} {
+} -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 [openpipe r cat longfile]
+} -constraints {stdio openpipe} -body {
+ chan flush $fd
+} -returnCodes error -cleanup {
+ catch {chan close $fd}
+} -match glob -result {channel "*" wasn't opened for writing}
+test chan-io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
chan puts $f1 hello
chan puts $f1 hello
chan puts $f1 hello
chan flush $f1
- set x [file size $path(test1)]
+ file size $path(test1)
+} -cleanup {
chan close $f1
- set x
-} 18
-test chan-io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} {
+} -result 18
+test chan-io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} -setup {
file delete $path(test1)
set x ""
set f1 [open $path(test1) w]
+} -body {
chan configure $f1 -translation lf
chan puts $f1 hello
chan puts $f1 hello
@@ -2428,11 +2489,12 @@ test chan-io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} {
chan puts $f1 hello
chan flush $f1
lappend x [file size $path(test1)]
+} -cleanup {
chan close $f1
- set x
-} {18 24 30}
-test chan-io-29.19 {Explicit and implicit flushes} {
+} -result {18 24 30}
+test chan-io-29.19 {Explicit and implicit flushes} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf -eofchar {}
set x ""
@@ -2447,10 +2509,10 @@ test chan-io-29.19 {Explicit and implicit flushes} {
chan puts $f1 hello
chan close $f1
lappend x [file size $path(test1)]
- set x
-} {18 24 30}
-test chan-io-29.20 {Implicit flush when buffer is full} {
+} -result {18 24 30}
+test chan-io-29.20 {Implicit flush when buffer is full} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf -eofchar {}
set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
@@ -2465,24 +2527,25 @@ test chan-io-29.20 {Implicit flush when buffer is full} {
lappend z [file size $path(test1)]
chan close $f1
lappend z [file size $path(test1)]
- set z
-} {4096 12288 12600}
-test chan-io-29.21 {Tcl_Flush to pipe} {stdio openpipe} {
+} -result {4096 12288 12600}
+test chan-io-29.21 {Tcl_Flush to pipe} -setup {
file delete $path(pipe)
+} -constraints {stdio openpipe} -body {
set f1 [open $path(pipe) w]
chan puts $f1 {set x [chan read stdin 6]}
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
- set x [chan gets $f1]
+ chan gets $f1
+} -cleanup {
catch {chan close $f1}
- set x
-} "read 6 characters"
-test chan-io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} {
+} -result "read 6 characters"
+test chan-io-29.22 {Tcl_Flush called at other end of pipe} -setup {
file delete $path(pipe)
+} -constraints {stdio openpipe} -body {
set f1 [open $path(pipe) w]
chan puts $f1 {
chan configure stdout -buffering full
@@ -2494,18 +2557,19 @@ test chan-io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} {
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]
chan puts $f1 hello
chan flush $f1
lappend x [chan gets $f1]
+} -cleanup {
chan close $f1
- set x
-} {hello hello bye}
-test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio openpipe} {
+} -result {hello hello bye}
+test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} -setup {
file delete $path(pipe)
+} -constraints {stdio openpipe} -body {
set f1 [open $path(pipe) w]
chan puts $f1 {
chan puts hello
@@ -2514,108 +2578,112 @@ test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio openpipe
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]
chan puts $f1 hello
chan flush $f1
lappend x [chan gets $f1]
+} -cleanup {
chan close $f1
- set x
-} {hello hello bye}
-test chan-io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} {
+} -result {hello hello bye}
+test chan-io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} -setup {
+ variable x {}
+} -body {
set f [open $path(test3) w]
chan puts $f "Line 1"
chan puts $f "Line 2"
set f2 [open $path(test3)]
- set x {}
lappend x [chan read -nonewline $f2]
chan close $f2
chan flush $f
set f2 [open $path(test3)]
lappend x [chan read -nonewline $f2]
+} -cleanup {
chan close $f2
chan close $f
- set x
-} "{} {Line 1\nLine 2}"
-test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpipe fileevent} {
+} -result "{} {Line 1\nLine 2}"
+test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} -setup {
file delete $path(test3)
- set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w]
+} -constraints {stdio openpipe fileevent} -body {
+ set f [openpipe w $path(cat) | [interpreter] $path(cat) > $path(test3)]
chan puts $f "Line 1"
chan puts $f "Line 2"
chan close $f
after 100
set f [open $path(test3) r]
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "Line 1\nLine 2\n"
-test chan-io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs openpipe} {
+} -result "Line 1\nLine 2\n"
+test chan-io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} -constraints {stdio unixExecs openpipe} -body {
set f [open "|[list cat -u]" r+]
chan puts $f "Line1"
chan flush $f
- set x [chan gets $f]
+ chan gets $f
+} -cleanup {
chan close $f
- set x
-} {Line1}
-test chan-io-29.27 {Tcl_Flush on chan closed pipeline} {stdio openpipe} {
+} -result {Line1}
+test chan-io-29.27 {Tcl_Flush on chan closed pipeline} -setup {
file delete $path(pipe)
set f [open $path(pipe) w]
chan puts $f {exit}
chan close $f
- set f [open "|[list [interpreter] $path(pipe)]" r+]
+} -constraints {stdio openpipe} -body {
+ set f [openpipe r+ $path(pipe)]
chan gets $f
chan puts $f output
after 50
#
- # The flush below will get a SIGPIPE. This is an expected part of
- # test and indicates that the test operates correctly. If you run
- # this test under a debugger, the signal will by intercepted unless
- # you disable the debugger's signal interception.
+ # The flush below will get a SIGPIPE. This is an expected part of the test
+ # and indicates that the test operates correctly. If you run this test
+ # under a debugger, the signal will by intercepted unless you disable the
+ # debugger's signal interception.
#
if {[catch {chan flush $f} msg]} {
set x [list 1 $msg $::errorCode]
catch {chan close $f}
+ } elseif {[catch {chan close $f} msg]} {
+ set x [list 1 $msg $::errorCode]
} else {
- if {[catch {chan close $f} msg]} {
- set x [list 1 $msg $::errorCode]
- } else {
- set x {this was supposed to fail and did not}
- }
+ set x {this was supposed to fail and did not}
}
- regsub {".*":} $x {"":} x
string tolower $x
-} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}}
-test chan-io-29.28 {Tcl_WriteChars, lf mode} {
+} -match glob -result {1 {error flushing "*": broken pipe} {posix epipe {broken pipe}}}
+test chan-io-29.28 {Tcl_WriteChars, lf mode} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -eofchar {}
chan puts $f hello\nthere\nand\nhere
chan flush $f
- set s [file size $path(test1)]
+ file size $path(test1)
+} -cleanup {
chan close $f
- set s
-} 21
-test chan-io-29.29 {Tcl_WriteChars, cr mode} {
+} -result 21
+test chan-io-29.29 {Tcl_WriteChars, cr mode} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation cr -eofchar {}
chan puts $f hello\nthere\nand\nhere
chan close $f
file size $path(test1)
-} 21
-test chan-io-29.30 {Tcl_WriteChars, crlf mode} {
+} -result 21
+test chan-io-29.30 {Tcl_WriteChars, crlf mode} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf -eofchar {}
chan puts $f hello\nthere\nand\nhere
chan close $f
file size $path(test1)
-} 25
-test chan-io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} {
+} -result 25
+test chan-io-29.31 {Tcl_WriteChars, background flush} -setup {
file delete $path(pipe)
file delete $path(output)
+} -constraints {stdio openpipe} -body {
set f [open $path(pipe) w]
chan puts $f "set f \[[list open $path(output) w]]"
chan puts $f {chan configure $f -translation lf}
@@ -2633,7 +2701,7 @@ test chan-io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} {
}
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
@@ -2651,12 +2719,12 @@ test chan-io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} {
# otherwise, the following test fails on the [file delete $path(output)
# on Windows because a process still has the file open.
after 100 set v 1; vwait v
- set result
-} ok
-test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} \
- {stdio asyncPipeChan Close openpipe} {
+ return $result
+} -result ok
+test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} -setup {
file delete $path(pipe)
file delete $path(output)
+} -constraints {stdio asyncPipeChan Close openpipe} -body {
set f [open $path(pipe) w]
chan puts $f "set f \[[list open $path(output) w]]"
chan puts $f {chan configure $f -translation lf}
@@ -2675,7 +2743,7 @@ test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} \
}
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
@@ -2689,8 +2757,8 @@ test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} \
} else {
set result ok
}
-} ok
-test chan-io-29.33 {Tcl_Flush, implicit flush on exit} {exec} {
+} -result ok
+test chan-io-29.33 {Tcl_Flush, implicit flush on exit} -setup {
set f [open $path(script) w]
chan puts $f "set f \[[list open $path(test1) w]]"
chan puts $f {chan configure $f -translation lf
@@ -2699,13 +2767,14 @@ test chan-io-29.33 {Tcl_Flush, implicit flush on exit} {exec} {
chan puts $f strange
}
chan close $f
+} -constraints exec -body {
exec [interpreter] $path(script)
set f [open $path(test1) r]
- set r [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set r
-} "hello\nbye\nstrange\n"
-test chan-io-29.34 {Tcl_Chan Close, async flush on chan close, using sockets} {socket tempNotMac fileevent} {
+} -result "hello\nbye\nstrange\n"
+test chan-io-29.34 {Tcl_Chan Close, async flush on chan close, using sockets} -setup {
variable c 0
variable x running
set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
@@ -2714,6 +2783,7 @@ test chan-io-29.34 {Tcl_Chan Close, async flush on chan close, using sockets} {s
chan puts $s $l
}
}
+} -constraints {socket tempNotMac fileevent} -body {
proc accept {s a p} {
variable x
chan event $s readable [namespace code [list readit $s]]
@@ -2739,13 +2809,14 @@ test chan-io-29.34 {Tcl_Chan Close, async flush on chan close, using sockets} {s
chan close $cs
chan close $ss
vwait [namespace which -variable x]
- set c
-} 2000
-test chan-io-29.35 {Tcl_Chan Close vs chan event vs multiple interpreters} {socket tempNotMac fileevent} {
- # On Mac, this test screws up sockets such that subsequent tests using
- # port 2828 either cause errors or panic().
+ return $c
+} -result 2000
+test chan-io-29.35 {Tcl_Chan Close vs chan event vs multiple interpreters} -setup {
catch {interp delete x}
catch {interp delete y}
+} -constraints {socket tempNotMac fileevent} -body {
+ # On Mac, this test screws up sockets such that subsequent tests using
+ # port 2828 either cause errors or panic().
interp create x
interp create y
set s [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
@@ -2777,171 +2848,182 @@ test chan-io-29.35 {Tcl_Chan Close vs chan event vs multiple interpreters} {sock
y eval "chan event $c readable \{readit $c\}"
y eval [list chan close $c]
update
+} -cleanup {
chan close $s
interp delete x
interp delete y
-} ""
+} -result ""
# Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read.
-test chan-io-30.1 {Tcl_Write lf, Tcl_Read lf} {
+test chan-io-30.1 {Tcl_Write lf, Tcl_Read lf} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation lf
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "hello\nthere\nand\nhere\n"
-test chan-io-30.2 {Tcl_Write lf, Tcl_Read cr} {
+} -result "hello\nthere\nand\nhere\n"
+test chan-io-30.2 {Tcl_Write lf, Tcl_Read cr} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation cr
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "hello\nthere\nand\nhere\n"
-test chan-io-30.3 {Tcl_Write lf, Tcl_Read crlf} {
+} -result "hello\nthere\nand\nhere\n"
+test chan-io-30.3 {Tcl_Write lf, Tcl_Read crlf} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "hello\nthere\nand\nhere\n"
-test chan-io-30.4 {Tcl_Write cr, Tcl_Read cr} {
+} -result "hello\nthere\nand\nhere\n"
+test chan-io-30.4 {Tcl_Write cr, Tcl_Read cr} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation cr
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "hello\nthere\nand\nhere\n"
-test chan-io-30.5 {Tcl_Write cr, Tcl_Read lf} {
+} -result "hello\nthere\nand\nhere\n"
+test chan-io-30.5 {Tcl_Write cr, Tcl_Read lf} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation lf
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "hello\rthere\rand\rhere\r"
-test chan-io-30.6 {Tcl_Write cr, Tcl_Read crlf} {
+} -result "hello\rthere\rand\rhere\r"
+test chan-io-30.6 {Tcl_Write cr, Tcl_Read crlf} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "hello\rthere\rand\rhere\r"
-test chan-io-30.7 {Tcl_Write crlf, Tcl_Read crlf} {
+} -result "hello\rthere\rand\rhere\r"
+test chan-io-30.7 {Tcl_Write crlf, Tcl_Read crlf} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "hello\nthere\nand\nhere\n"
-test chan-io-30.8 {Tcl_Write crlf, Tcl_Read lf} {
+} -result "hello\nthere\nand\nhere\n"
+test chan-io-30.8 {Tcl_Write crlf, Tcl_Read lf} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation lf
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "hello\r\nthere\r\nand\r\nhere\r\n"
-test chan-io-30.9 {Tcl_Write crlf, Tcl_Read cr} {
+} -result "hello\r\nthere\r\nand\r\nhere\r\n"
+test chan-io-30.9 {Tcl_Write crlf, Tcl_Read cr} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation cr
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} "hello\n\nthere\n\nand\n\nhere\n\n"
-test chan-io-30.10 {Tcl_Write lf, Tcl_Read auto} {
+} -result "hello\n\nthere\n\nand\n\nhere\n\n"
+test chan-io-30.10 {Tcl_Write lf, Tcl_Read auto} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
- set c [chan read $f]
- set x [chan configure $f -translation]
+ list [chan read $f] [chan configure $f -translation]
+} -cleanup {
chan close $f
- list $c $x
-} {{hello
+} -result {{hello
there
and
here
} auto}
-test chan-io-30.11 {Tcl_Write cr, Tcl_Read auto} {
+test chan-io-30.11 {Tcl_Write cr, Tcl_Read auto} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
- set c [chan read $f]
- set x [chan configure $f -translation]
+ list [chan read $f] [chan configure $f -translation]
+} -cleanup {
chan close $f
- list $c $x
-} {{hello
+} -result {{hello
there
and
here
} auto}
-test chan-io-30.12 {Tcl_Write crlf, Tcl_Read auto} {
+test chan-io-30.12 {Tcl_Write crlf, Tcl_Read auto} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
- set c [chan read $f]
- set x [chan configure $f -translation]
+ list [chan read $f] [chan configure $f -translation]
+} -cleanup {
chan close $f
- list $c $x
-} {{hello
+} -result {{hello
there
and
here
} auto}
-test chan-io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} {
+test chan-io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
@@ -2952,12 +3034,13 @@ test chan-io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} {
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto
- set c [chan read $f]
+ string length [chan read $f]
+} -cleanup {
chan close $f
- string length $c
-} [expr 700*15+1]
-test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} {
+} -result [expr 700*15+1]
+test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
@@ -2968,60 +3051,64 @@ test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} {
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf
- set c [chan read $f]
+ string length [chan read $f]
+} -cleanup {
chan close $f
- string length $c
-} [expr 700*15+1]
-test chan-io-30.15 {Tcl_Write mixed, Tcl_Read auto} {
+} -result [expr 700*15+1]
+test chan-io-30.15 {Tcl_Write mixed, Tcl_Read auto} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f hello\nthere\nand\rhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto
- set c [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set c
-} {hello
+} -result {hello
there
and
here
}
-test chan-io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} {
+test chan-io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f hello\nthere\nand\rhere\n\x1a
chan close $f
set f [open $path(test1) r]
chan configure $f -eofchar \x1a -translation auto
- set c [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set c
-} {hello
+} -result {hello
there
and
here
}
-test chan-io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {win} {
+test chan-io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} -setup {
file delete $path(test1)
+} -constraints {win} -body {
set f [open $path(test1) w]
chan configure $f -eofchar \x1a -translation lf
chan puts $f hello\nthere\nand\rhere
chan close $f
set f [open $path(test1) r]
chan configure $f -eofchar \x1a -translation auto
- set c [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set c
-} {hello
+} -result {hello
there
and
here
}
-test chan-io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} {
+test chan-io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
set s [format "abc\ndef\n%cghi\nqrs" 26]
@@ -3037,11 +3124,12 @@ test chan-io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} {
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {abc def 0 {} 1 {} 1}
-test chan-io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} {
+} -result {abc def 0 {} 1 {} 1}
+test chan-io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
set s [format "abc\ndef\n%cghi\nqrs" 26]
@@ -3057,19 +3145,19 @@ test chan-io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} {
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {abc def 0 {} 1 {} 1}
-test chan-io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} {
+} -result {abc def 0 {} 1 {} 1}
+test chan-io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -eofchar {}
- set s [format "abc\ndef\n%cghi\nqrs" 26]
- chan puts $f $s
+ chan puts $f [format "abc\ndef\n%cghi\nqrs" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation lf -eofchar {}
- set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
@@ -3079,61 +3167,61 @@ test chan-io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} {
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} "abc def 0 \x1aghi 0 qrs 0 {} 1"
-test chan-io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} {
+} -result "abc def 0 \x1aghi 0 qrs 0 {} 1"
+test chan-io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -eofchar {}
- set s [format "abc\ndef\n%cghi\nqrs" 26]
- chan puts $f $s
+ chan puts $f [format "abc\ndef\n%cghi\nqrs" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation cr -eofchar {}
- set l ""
set x [chan gets $f]
- lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"]
+ lappend l [string equal $x "abc\ndef\n\x1aghi\nqrs\n"]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {0 1 {} 1}
-test chan-io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} {
+} -result {1 1 {} 1}
+test chan-io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -eofchar {}
- set s [format "abc\ndef\n%cghi\nqrs" 26]
- chan puts $f $s
+ chan puts $f [format "abc\ndef\n%cghi\nqrs" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf -eofchar {}
- set l ""
set x [chan gets $f]
- lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"]
+ lappend l [string equal $x "abc\ndef\n\x1aghi\nqrs\n"]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {0 1 {} 1}
-test chan-io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} {
+} -result {1 1 {} 1}
+test chan-io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
- set c [format abc\ndef\n%cqrs\ntuv 26]
- chan puts $f $c
+ chan puts $f [format abc\ndef\n%cqrs\ntuv 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1a
- set c [string length [chan read $f]]
- set e [chan eof $f]
+ list [string length [chan read $f]] [chan eof $f]
+} -cleanup {
chan close $f
- list $c $e
-} {8 1}
-test chan-io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} {
+} -result {8 1}
+test chan-io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
set c [format abc\ndef\n%cqrs\ntuv 26]
@@ -3141,13 +3229,13 @@ test chan-io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} {
chan close $f
set f [open $path(test1) r]
chan configure $f -translation lf -eofchar \x1a
- set c [string length [chan read $f]]
- set e [chan eof $f]
+ list [string length [chan read $f]] [chan eof $f]
+} -cleanup {
chan close $f
- list $c $e
-} {8 1}
-test chan-io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} {
+} -result {8 1}
+test chan-io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
set c [format abc\ndef\n%cqrs\ntuv 26]
@@ -3155,13 +3243,13 @@ test chan-io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} {
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1a
- set c [string length [chan read $f]]
- set e [chan eof $f]
+ list [string length [chan read $f]] [chan eof $f]
+} -cleanup {
chan close $f
- list $c $e
-} {8 1}
-test chan-io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} {
+} -result {8 1}
+test chan-io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
set c [format abc\ndef\n%cqrs\ntuv 26]
@@ -3169,13 +3257,13 @@ test chan-io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} {
chan close $f
set f [open $path(test1) r]
chan configure $f -translation cr -eofchar \x1a
- set c [string length [chan read $f]]
- set e [chan eof $f]
+ list [string length [chan read $f]] [chan eof $f]
+} -cleanup {
chan close $f
- list $c $e
-} {8 1}
-test chan-io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} {
+} -result {8 1}
+test chan-io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
set c [format abc\ndef\n%cqrs\ntuv 26]
@@ -3183,13 +3271,13 @@ test chan-io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} {
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1a
- set c [string length [chan read $f]]
- set e [chan eof $f]
+ list [string length [chan read $f]] [chan eof $f]
+} -cleanup {
chan close $f
- list $c $e
-} {8 1}
-test chan-io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} {
+} -result {8 1}
+test chan-io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
set c [format abc\ndef\n%cqrs\ntuv 26]
@@ -3197,92 +3285,97 @@ test chan-io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} {
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf -eofchar \x1a
- set c [string length [chan read $f]]
- set e [chan eof $f]
+ list [string length [chan read $f]] [chan eof $f]
+} -cleanup {
chan close $f
- list $c $e
-} {8 1}
+} -result {8 1}
-# Test end of line translations. Functions tested are Tcl_Write and Tcl_Gets.
+# Test end of line translations. Functions tested are Tcl_Write and
+# Tcl_Gets.
-test chan-io-31.1 {Tcl_Write lf, Tcl_Gets auto} {
+test chan-io-31.1 {Tcl_Write lf, Tcl_Gets auto} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
- set l ""
lappend l [chan gets $f]
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
lappend l [chan gets $f]
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
+} -cleanup {
chan close $f
- set l
-} {hello 6 auto there 12 auto}
-test chan-io-31.2 {Tcl_Write cr, Tcl_Gets auto} {
+} -result {hello 6 auto there 12 auto}
+test chan-io-31.2 {Tcl_Write cr, Tcl_Gets auto} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
- set l ""
lappend l [chan gets $f]
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
lappend l [chan gets $f]
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
+} -cleanup {
chan close $f
- set l
-} {hello 6 auto there 12 auto}
-test chan-io-31.3 {Tcl_Write crlf, Tcl_Gets auto} {
+} -result {hello 6 auto there 12 auto}
+test chan-io-31.3 {Tcl_Write crlf, Tcl_Gets auto} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
- set l ""
lappend l [chan gets $f]
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
lappend l [chan gets $f]
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
+} -cleanup {
chan close $f
- set l
-} {hello 7 auto there 14 auto}
-test chan-io-31.4 {Tcl_Write lf, Tcl_Gets lf} {
+} -result {hello 7 auto there 14 auto}
+test chan-io-31.4 {Tcl_Write lf, Tcl_Gets lf} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation lf
- set l ""
lappend l [chan gets $f]
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
lappend l [chan gets $f]
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
+} -cleanup {
chan close $f
- set l
-} {hello 6 lf there 12 lf}
-test chan-io-31.5 {Tcl_Write lf, Tcl_Gets cr} {
+} -result {hello 6 lf there 12 lf}
+test chan-io-31.5 {Tcl_Write lf, Tcl_Gets cr} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation cr
- set l ""
lappend l [string length [chan gets $f]]
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
@@ -3291,18 +3384,19 @@ test chan-io-31.5 {Tcl_Write lf, Tcl_Gets cr} {
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {21 21 cr 1 {} 21 cr 1}
-test chan-io-31.6 {Tcl_Write lf, Tcl_Gets crlf} {
+} -result {21 21 cr 1 {} 21 cr 1}
+test chan-io-31.6 {Tcl_Write lf, Tcl_Gets crlf} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf
- set l ""
lappend l [string length [chan gets $f]]
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
@@ -3311,18 +3405,19 @@ test chan-io-31.6 {Tcl_Write lf, Tcl_Gets crlf} {
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {21 21 crlf 1 {} 21 crlf 1}
-test chan-io-31.7 {Tcl_Write cr, Tcl_Gets cr} {
+} -result {21 21 crlf 1 {} 21 crlf 1}
+test chan-io-31.7 {Tcl_Write cr, Tcl_Gets cr} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation cr
- set l ""
lappend l [chan gets $f]
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
@@ -3331,18 +3426,19 @@ test chan-io-31.7 {Tcl_Write cr, Tcl_Gets cr} {
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {hello 6 cr 0 there 12 cr 0}
-test chan-io-31.8 {Tcl_Write cr, Tcl_Gets lf} {
+} -result {hello 6 cr 0 there 12 cr 0}
+test chan-io-31.8 {Tcl_Write cr, Tcl_Gets lf} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation lf
- set l ""
lappend l [string length [chan gets $f]]
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
@@ -3351,18 +3447,19 @@ test chan-io-31.8 {Tcl_Write cr, Tcl_Gets lf} {
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {21 21 lf 1 {} 21 lf 1}
-test chan-io-31.9 {Tcl_Write cr, Tcl_Gets crlf} {
+} -result {21 21 lf 1 {} 21 lf 1}
+test chan-io-31.9 {Tcl_Write cr, Tcl_Gets crlf} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf
- set l ""
lappend l [string length [chan gets $f]]
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
@@ -3371,18 +3468,19 @@ test chan-io-31.9 {Tcl_Write cr, Tcl_Gets crlf} {
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {21 21 crlf 1 {} 21 crlf 1}
-test chan-io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} {
+} -result {21 21 crlf 1 {} 21 crlf 1}
+test chan-io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf
- set l ""
lappend l [chan gets $f]
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
@@ -3391,18 +3489,19 @@ test chan-io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} {
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {hello 7 crlf 0 there 14 crlf 0}
-test chan-io-31.11 {Tcl_Write crlf, Tcl_Gets cr} {
+} -result {hello 7 crlf 0 there 14 crlf 0}
+test chan-io-31.11 {Tcl_Write crlf, Tcl_Gets cr} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation cr
- set l ""
lappend l [chan gets $f]
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
@@ -3411,18 +3510,19 @@ test chan-io-31.11 {Tcl_Write crlf, Tcl_Gets cr} {
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {hello 6 cr 0 6 13 cr 0}
-test chan-io-31.12 {Tcl_Write crlf, Tcl_Gets lf} {
+} -result {hello 6 cr 0 6 13 cr 0}
+test chan-io-31.12 {Tcl_Write crlf, Tcl_Gets lf} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f hello\nthere\nand\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation lf
- set l ""
lappend l [string length [chan gets $f]]
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
@@ -3431,30 +3531,32 @@ test chan-io-31.12 {Tcl_Write crlf, Tcl_Gets lf} {
lappend l [chan tell $f]
lappend l [chan configure $f -translation]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {6 7 lf 0 6 14 lf 0}
-test chan-io-31.13 {binary mode is synonym of lf mode} {
+} -result {6 7 lf 0 6 14 lf 0}
+test chan-io-31.13 {binary mode is synonym of lf mode} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation binary
- set x [chan configure $f -translation]
+ chan configure $f -translation
+} -cleanup {
chan close $f
- set x
-} lf
+} -result lf
#
# Test chan-io-9.14 has been removed because "auto" output translation mode is
# not supoprted.
#
-test chan-io-31.14 {Tcl_Write mixed, Tcl_Gets auto} {
+test chan-io-31.14 {Tcl_Write mixed, Tcl_Gets auto} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f hello\nthere\rand\r\nhere
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto
- set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan gets $f]
@@ -3462,18 +3564,19 @@ test chan-io-31.14 {Tcl_Write mixed, Tcl_Gets auto} {
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {hello there and here 0 {} 1}
-test chan-io-31.15 {Tcl_Write mixed, Tcl_Gets auto} {
+} -result {hello there and here 0 {} 1}
+test chan-io-31.15 {Tcl_Write mixed, Tcl_Gets auto} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f hello\nthere\rand\r\nhere\r
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto
- set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan gets $f]
@@ -3481,17 +3584,18 @@ test chan-io-31.15 {Tcl_Write mixed, Tcl_Gets auto} {
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {hello there and here 0 {} 1}
-test chan-io-31.16 {Tcl_Write mixed, Tcl_Gets auto} {
+} -result {hello there and here 0 {} 1}
+test chan-io-31.16 {Tcl_Write mixed, Tcl_Gets auto} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f hello\nthere\rand\r\nhere\n
chan close $f
set f [open $path(test1) r]
- set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan gets $f]
@@ -3499,18 +3603,19 @@ test chan-io-31.16 {Tcl_Write mixed, Tcl_Gets auto} {
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {hello there and here 0 {} 1}
-test chan-io-31.17 {Tcl_Write mixed, Tcl_Gets auto} {
+} -result {hello there and here 0 {} 1}
+test chan-io-31.17 {Tcl_Write mixed, Tcl_Gets auto} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f hello\nthere\rand\r\nhere\r\n
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto
- set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan gets $f]
@@ -3518,19 +3623,19 @@ test chan-io-31.17 {Tcl_Write mixed, Tcl_Gets auto} {
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {hello there and here 0 {} 1}
-test chan-io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} {
+} -result {hello there and here 0 {} 1}
+test chan-io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
- set s [format "hello\nthere\nand\rhere\n\%c" 26]
- chan puts $f $s
+ chan puts $f [format "hello\nthere\nand\rhere\n\%c" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -eofchar \x1a -translation auto
- set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan gets $f]
@@ -3538,18 +3643,19 @@ test chan-io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} {
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {hello there and here 0 {} 1}
-test chan-io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} {
+} -result {hello there and here 0 {} 1}
+test chan-io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -eofchar \x1a -translation lf
chan puts $f hello\nthere\nand\rhere
chan close $f
set f [open $path(test1) r]
chan configure $f -eofchar \x1a -translation auto
- set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan gets $f]
@@ -3557,56 +3663,56 @@ test chan-io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} {
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {hello there and here 0 {} 1}
-test chan-io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} {
+} -result {hello there and here 0 {} 1}
+test chan-io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
- set s [format "abc\ndef\n%cqrs\ntuv" 26]
- chan puts $f $s
+ chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -eofchar \x1a
chan configure $f -translation auto
- set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {abc def 0 {} 1}
-test chan-io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} {
+} -result {abc def 0 {} 1}
+test chan-io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
- set s [format "abc\ndef\n%cqrs\ntuv" 26]
- chan puts $f $s
+ chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -eofchar \x1a -translation auto
- set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {abc def 0 {} 1}
-test chan-io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} {
+} -result {abc def 0 {} 1}
+test chan-io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -eofchar {}
- set s [format "abc\ndef\n%cqrs\ntuv" 26]
- chan puts $f $s
+ chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation lf -eofchar {}
- set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
@@ -3616,19 +3722,19 @@ test chan-io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} {
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
-test chan-io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} {
+} -result "abc def 0 \x1aqrs 0 tuv 0 {} 1"
+test chan-io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation cr -eofchar {}
- set s [format "abc\ndef\n%cqrs\ntuv" 26]
- chan puts $f $s
+ chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation cr -eofchar {}
- set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
@@ -3638,19 +3744,19 @@ test chan-io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} {
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
-test chan-io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} {
+} -result "abc def 0 \x1aqrs 0 tuv 0 {} 1"
+test chan-io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf -eofchar {}
- set s [format "abc\ndef\n%cqrs\ntuv" 26]
- chan puts $f $s
+ chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf -eofchar {}
- set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
@@ -3660,119 +3766,121 @@ test chan-io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} {
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
-test chan-io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} {
+} -result "abc def 0 \x1aqrs 0 tuv 0 {} 1"
+test chan-io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
- set s [format "abc\ndef\n%cqrs\ntuv" 26]
- chan puts $f $s
+ chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1a
- set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {abc def 0 {} 1}
-test chan-io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} {
+} -result {abc def 0 {} 1}
+test chan-io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
- set s [format "abc\ndef\n%cqrs\ntuv" 26]
- chan puts $f $s
+ chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation lf -eofchar \x1a
- set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {abc def 0 {} 1}
-test chan-io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} {
+} -result {abc def 0 {} 1}
+test chan-io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation cr -eofchar {}
- set s [format "abc\ndef\n%cqrs\ntuv" 26]
- chan puts $f $s
+ chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1a
- set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {abc def 0 {} 1}
-test chan-io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} {
+} -result {abc def 0 {} 1}
+test chan-io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation cr -eofchar {}
- set s [format "abc\ndef\n%cqrs\ntuv" 26]
- chan puts $f $s
+ chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation cr -eofchar \x1a
- set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {abc def 0 {} 1}
-test chan-io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} {
+} -result {abc def 0 {} 1}
+test chan-io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf -eofchar {}
- set s [format "abc\ndef\n%cqrs\ntuv" 26]
- chan puts $f $s
+ chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1a
- set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {abc def 0 {} 1}
-test chan-io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} {
+} -result {abc def 0 {} 1}
+test chan-io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf -eofchar {}
- set s [format "abc\ndef\n%cqrs\ntuv" 26]
- chan puts $f $s
+ chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf -eofchar \x1a
- set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {abc def 0 {} 1}
-test chan-io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} {
+} -result {abc def 0 {} 1}
+test chan-io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} -setup {
file delete $path(test1)
+ set c ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
@@ -3783,15 +3891,16 @@ test chan-io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} {
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf
- set c ""
while {[chan gets $f line] >= 0} {
append c $line\n
}
chan close $f
string length $c
-} [expr 700*15+1]
-test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} {
+} -result [expr 700*15+1]
+test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} -setup {
file delete $path(test1)
+ set c ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
@@ -3802,45 +3911,41 @@ test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} {
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto
- set c ""
while {[chan gets $f line] >= 0} {
append c $line\n
}
chan close $f
string length $c
-} [expr 700*15+1]
+} -result [expr 700*15+1]
# Test Tcl_Read and buffering.
-test chan-io-32.1 {Tcl_Read, channel not readable} {
- list [catch {read stdout} msg] $msg
-} {1 {channel "stdout" wasn't opened for reading}}
+test chan-io-32.1 {Tcl_Read, channel not readable} -body {
+ read stdout
+} -returnCodes error -result {channel "stdout" wasn't opened for reading}
test chan-io-32.2 {Tcl_Read, zero byte count} {
chan read stdin 0
} ""
-test chan-io-32.3 {Tcl_Read, negative byte count} {
+test chan-io-32.3 {Tcl_Read, negative byte count} -setup {
set f [open $path(longfile) r]
- set l [list [catch {chan read $f -1} msg] $msg]
+} -body {
+ chan read $f -1
+} -returnCodes error -cleanup {
chan close $f
- set l
-} {1 {bad argument "-1": should be "nonewline"}}
-test chan-io-32.4 {Tcl_Read, positive byte count} {
+} -result {bad argument "-1": should be "nonewline"}
+test chan-io-32.4 {Tcl_Read, positive byte count} -body {
set f [open $path(longfile) r]
- set x [chan read $f 1024]
- set s [string length $x]
- unset x
+ string length [chan read $f 1024]
+} -cleanup {
chan close $f
- set s
-} 1024
-test chan-io-32.5 {Tcl_Read, multiple buffers} {
+} -result 1024
+test chan-io-32.5 {Tcl_Read, multiple buffers} -body {
set f [open $path(longfile) r]
chan configure $f -buffersize 100
- set x [chan read $f 1024]
- set s [string length $x]
- unset x
+ string length [chan read $f 1024]
+} -cleanup {
chan close $f
- set s
-} 1024
+} -result 1024
test chan-io-32.6 {Tcl_Read, very large read} {
set f1 [open $path(longfile) r]
set z [chan read $f1 1000000]
@@ -3849,7 +3954,7 @@ test chan-io-32.6 {Tcl_Read, very large read} {
set x ok
set z [file size $path(longfile)]
if {$z != $l} {
- set x broken
+ set x "$z != $l"
}
set x
} ok
@@ -3861,7 +3966,7 @@ test chan-io-32.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
set l [string length $z]
set x ok
if {$l != 20} {
- set x broken
+ set x "$l != 20"
}
set x
} ok
@@ -3874,7 +3979,7 @@ test chan-io-32.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
set l [string length $z]
set z [file size $path(longfile)]
if {$z != $l} {
- set x broken
+ set x "$z != $l"
}
set x
} ok
@@ -3886,121 +3991,125 @@ test chan-io-32.9 {Tcl_Read, read to end of file} {
set x ok
set z [file size $path(longfile)]
if {$z != $l} {
- set x broken
+ set x "$z != $l"
}
set x
} ok
-test chan-io-32.10 {Tcl_Read from a pipe} {stdio openpipe} {
+test chan-io-32.10 {Tcl_Read from a pipe} -setup {
file delete $path(pipe)
+} -constraints {stdio openpipe} -body {
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
- set x [chan read $f1]
+ chan read $f1
+} -cleanup {
chan close $f1
- set x
-} "hello\n"
-test chan-io-32.11 {Tcl_Read from a pipe} {stdio openpipe} {
+} -result "hello\n"
+test chan-io-32.11 {Tcl_Read from a pipe} -setup {
file delete $path(pipe)
+ set x ""
+} -constraints {stdio openpipe} -body {
set f1 [open $path(pipe) w]
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
- set x ""
lappend x [chan read $f1 6]
chan puts $f1 hello
chan flush $f1
lappend x [chan read $f1]
+} -cleanup {
chan close $f1
- set x
-} {{hello
+} -result {{hello
} {hello
}}
-test chan-io-32.12 {Tcl_Read, -nonewline} {
+test chan-io-32.12 {Tcl_Read, -nonewline} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
chan puts $f1 hello
chan puts $f1 bye
chan close $f1
set f1 [open $path(test1) r]
- set c [chan read -nonewline $f1]
+ chan read -nonewline $f1
+} -cleanup {
chan close $f1
- set c
-} {hello
+} -result {hello
bye}
-test chan-io-32.13 {Tcl_Read, -nonewline} {
+test chan-io-32.13 {Tcl_Read, -nonewline} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
chan puts $f1 hello
chan puts $f1 bye
chan close $f1
set f1 [open $path(test1) r]
set c [chan read -nonewline $f1]
- chan close $f1
list [string length $c] $c
-} {9 {hello
+} -cleanup {
+ chan close $f1
+} -result {9 {hello
bye}}
-test chan-io-32.14 {Tcl_Read, reading in small chunks} {
+test chan-io-32.14 {Tcl_Read, reading in small chunks} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan puts $f "Two lines: this one"
chan puts $f "and this one"
chan close $f
set f [open $path(test1)]
- set x [list [chan read $f 1] [chan read $f 2] [chan read $f]]
+ list [chan read $f 1] [chan read $f 2] [chan read $f]
+} -cleanup {
chan close $f
- set x
-} {T wo { lines: this one
+} -result {T wo { lines: this one
and this one
}}
-test chan-io-32.15 {Tcl_Read, asking for more input than available} {
+test chan-io-32.15 {Tcl_Read, asking for more input than available} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan puts $f "Two lines: this one"
chan puts $f "and this one"
chan close $f
set f [open $path(test1)]
- set x [chan read $f 100]
+ chan read $f 100
+} -cleanup {
chan close $f
- set x
-} {Two lines: this one
+} -result {Two lines: this one
and this one
}
-test chan-io-32.16 {Tcl_Read, read to end of file with -nonewline} {
+test chan-io-32.16 {Tcl_Read, read to end of file with -nonewline} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan puts $f "Two lines: this one"
chan puts $f "and this one"
chan close $f
set f [open $path(test1)]
- set x [chan read -nonewline $f]
+ chan read -nonewline $f
+} -cleanup {
chan close $f
- set x
-} {Two lines: this one
+} -result {Two lines: this one
and this one}
# Test Tcl_Gets.
-test chan-io-33.1 {Tcl_Gets, reading what was written} {
+test chan-io-33.1 {Tcl_Gets, reading what was written} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
- set y "first line"
- chan puts $f1 $y
+ chan puts $f1 "first line"
chan close $f1
set f1 [open $path(test1) r]
- set x [chan gets $f1]
- set z ok
- if {"$x" != "$y"} {
- set z broken
- }
+ chan gets $f1
+} -cleanup {
chan close $f1
- set z
-} ok
+} -result {first line}
test chan-io-33.2 {Tcl_Gets into variable} {
set f1 [open $path(longfile) r]
set c [chan gets $f1 x]
@@ -4012,24 +4121,22 @@ test chan-io-33.2 {Tcl_Gets into variable} {
chan close $f1
set z
} ok
-test chan-io-33.3 {Tcl_Gets from pipe} {stdio openpipe} {
+test chan-io-33.3 {Tcl_Gets from pipe} -setup {
file delete $path(pipe)
+} -constraints {stdio openpipe} -body {
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
- set x [chan gets $f1]
+ chan gets $f1
+} -cleanup {
chan close $f1
- set z ok
- if {"$x" != "hello"} {
- set z broken
- }
- set z
-} ok
-test chan-io-33.4 {Tcl_Gets with long line} {
+} -result hello
+test chan-io-33.4 {Tcl_Gets with long line} -setup {
file delete $path(test3)
+} -body {
set f [open $path(test3) w]
chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
@@ -4038,44 +4145,46 @@ test chan-io-33.4 {Tcl_Gets with long line} {
chan puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
chan close $f
set f [open $path(test3)]
- set x [chan gets $f]
+ chan gets $f
+} -cleanup {
chan close $f
- set x
-} {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
+} -result {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
test chan-io-33.5 {Tcl_Gets with long line} {
set f [open $path(test3)]
set x [chan gets $f y]
chan close $f
list $x $y
} {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
-test chan-io-33.6 {Tcl_Gets and end of file} {
+test chan-io-33.6 {Tcl_Gets and end of file} -setup {
file delete $path(test3)
+ set x {}
+} -body {
set f [open $path(test3) w]
chan puts -nonewline $f "Test1\nTest2"
chan close $f
set f [open $path(test3)]
- set x {}
set y {}
lappend x [chan gets $f y] $y
set y {}
lappend x [chan gets $f y] $y
set y {}
lappend x [chan gets $f y] $y
+} -cleanup {
chan close $f
- set x
-} {5 Test1 5 Test2 -1 {}}
-test chan-io-33.7 {Tcl_Gets and bad variable} {
+} -result {5 Test1 5 Test2 -1 {}}
+test chan-io-33.7 {Tcl_Gets and bad variable} -setup {
set f [open $path(test3) w]
chan puts $f "Line 1"
chan puts $f "Line 2"
chan close $f
catch {unset x}
- set x 24
set f [open $path(test3) r]
- set result [list [catch {chan gets $f x(0)} msg] $msg]
+} -body {
+ set x 24
+ chan gets $f x(0)
+} -returnCodes error -cleanup {
chan close $f
- set result
-} {1 {can't set "x(0)": variable isn't array}}
+} -result {can't set "x(0)": variable isn't array}
test chan-io-33.8 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
chan configure $f -translation lf -eofchar {}
@@ -4118,15 +4227,16 @@ test chan-io-33.10 {Tcl_Gets, exercising double buffering} {
# Test Tcl_Seek and Tcl_Tell.
-test chan-io-34.1 {Tcl_Seek to current position at start of file} {
+test chan-io-34.1 {Tcl_Seek to current position at start of file} -body {
set f1 [open $path(longfile) r]
chan seek $f1 0 current
- set c [chan tell $f1]
+ chan tell $f1
+} -cleanup {
chan close $f1
- set c
-} 0
-test chan-io-34.2 {Tcl_Seek to offset from start} {
+} -result 0
+test chan-io-34.2 {Tcl_Seek to offset from start} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf -eofchar {}
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
@@ -4134,12 +4244,13 @@ test chan-io-34.2 {Tcl_Seek to offset from start} {
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 10 start
- set c [chan tell $f1]
+ chan tell $f1
+} -cleanup {
chan close $f1
- set c
-} 10
-test chan-io-34.3 {Tcl_Seek to end of file} {
+} -result 10
+test chan-io-34.3 {Tcl_Seek to end of file} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf -eofchar {}
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
@@ -4147,12 +4258,13 @@ test chan-io-34.3 {Tcl_Seek to end of file} {
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 0 end
- set c [chan tell $f1]
+ chan tell $f1
+} -cleanup {
chan close $f1
- set c
-} 54
-test chan-io-34.4 {Tcl_Seek to offset from end of file} {
+} -result 54
+test chan-io-34.4 {Tcl_Seek to offset from end of file} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf -eofchar {}
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
@@ -4160,12 +4272,13 @@ test chan-io-34.4 {Tcl_Seek to offset from end of file} {
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 -10 end
- set c [chan tell $f1]
+ chan tell $f1
+} -cleanup {
chan close $f1
- set c
-} 44
-test chan-io-34.5 {Tcl_Seek to offset from current position} {
+} -result 44
+test chan-io-34.5 {Tcl_Seek to offset from current position} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf -eofchar {}
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
@@ -4174,12 +4287,13 @@ test chan-io-34.5 {Tcl_Seek to offset from current position} {
set f1 [open $path(test1) r]
chan seek $f1 10 current
chan seek $f1 10 current
- set c [chan tell $f1]
+ chan tell $f1
+} -cleanup {
chan close $f1
- set c
-} 20
-test chan-io-34.6 {Tcl_Seek to offset from end of file} {
+} -result 20
+test chan-io-34.6 {Tcl_Seek to offset from end of file} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf -eofchar {}
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
@@ -4187,14 +4301,14 @@ test chan-io-34.6 {Tcl_Seek to offset from end of file} {
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 -10 end
- set c [chan tell $f1]
- set r [chan read $f1]
+ list [chan tell $f1] [chan read $f1]
+} -cleanup {
chan close $f1
- list $c $r
-} {44 {rstuvwxyz
+} -result {44 {rstuvwxyz
}}
-test chan-io-34.7 {Tcl_Seek to offset from end of file, then to current position} {
+test chan-io-34.7 {Tcl_Seek to offset from end of file, then to current position} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf -eofchar {}
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
@@ -4205,19 +4319,20 @@ test chan-io-34.7 {Tcl_Seek to offset from end of file, then to current position
set c1 [chan tell $f1]
set r1 [chan read $f1 5]
chan seek $f1 0 current
- set c2 [chan tell $f1]
- chan close $f1
- list $c1 $r1 $c2
-} {44 rstuv 49}
-test chan-io-34.8 {Tcl_Seek on pipes: not supported} {stdio openpipe} {
- set f1 [open "|[list [interpreter]]" r+]
- set x [list [catch {chan seek $f1 0 current} msg] $msg]
+ list $c1 $r1 [chan tell $f1]
+} -cleanup {
chan close $f1
- regsub {".*":} $x {"":} x
- string tolower $x
-} {1 {error during seek on "": invalid argument}}
-test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} {
+} -result {44 rstuv 49}
+test chan-io-34.8 {Tcl_Seek on pipes: not supported} -setup {
+ set pipe [openpipe]
+} -constraints {stdio openpipe} -body {
+ chan seek $pipe 0 current
+} -returnCodes error -cleanup {
+ chan close $pipe
+} -match glob -result {error during seek on "*": invalid argument}
+test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} -setup {
file delete $path(test3)
+} -body {
set f [open $path(test3) w]
chan configure $f -eofchar {}
chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
@@ -4236,9 +4351,9 @@ test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} {
lappend x [chan read $f 1]
chan seek $f 1
lappend x [chan read $f 1]
+} -cleanup {
chan close $f
- set x
-} {a d a l Y {} b}
+} -result {a d a l Y {} b}
set path(test3) [makeFile {} test3]
test chan-io-34.10 {Tcl_Seek testing flushing of buffered input} {
set f [open $path(test3) w]
@@ -4282,15 +4397,17 @@ test chan-io-34.12 {Tcl_Seek testing combination of write, seek back and read} {
} {14 {xyz
123
xyzzy} zzy}
-test chan-io-34.13 {Tcl_Tell at start of file} {
+test chan-io-34.13 {Tcl_Tell at start of file} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
- set p [chan tell $f1]
+ chan tell $f1
+} -cleanup {
chan close $f1
- set p
-} 0
-test chan-io-34.14 {Tcl_Tell after seek to end of file} {
+} -result 0
+test chan-io-34.14 {Tcl_Tell after seek to end of file} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf -eofchar {}
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
@@ -4298,12 +4415,13 @@ test chan-io-34.14 {Tcl_Tell after seek to end of file} {
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 0 end
- set c1 [chan tell $f1]
+ chan tell $f1
+} -cleanup {
chan close $f1
- set c1
-} 54
-test chan-io-34.15 {Tcl_Tell combined with seeking} {
+} -result 54
+test chan-io-34.15 {Tcl_Tell combined with seeking} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf -eofchar {}
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
@@ -4313,18 +4431,18 @@ test chan-io-34.15 {Tcl_Tell combined with seeking} {
chan seek $f1 10 start
set c1 [chan tell $f1]
chan seek $f1 10 current
- set c2 [chan tell $f1]
+ list $c1 [chan tell $f1]
+} -cleanup {
chan close $f1
- list $c1 $c2
-} {10 20}
-test chan-io-34.16 {Tcl_Tell on pipe: always -1} {stdio openpipe} {
- set f1 [open "|[list [interpreter]]" r+]
- set c [chan tell $f1]
+} -result {10 20}
+test chan-io-34.16 {Tcl_Tell on pipe: always -1} -constraints {stdio openpipe} -body {
+ set f1 [openpipe]
+ chan tell $f1
+} -cleanup {
chan close $f1
- set c
-} -1
+} -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]
@@ -4332,8 +4450,9 @@ test chan-io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} {
chan close $f1
set c
} -1
-test chan-io-34.18 {Tcl_Tell combined with seeking and reading} {
+test chan-io-34.18 {Tcl_Tell combined with seeking and reading} -setup {
file delete $path(test2)
+} -body {
set f [open $path(test2) w]
chan configure $f -translation lf -eofchar {}
chan puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n"
@@ -4349,23 +4468,24 @@ test chan-io-34.18 {Tcl_Tell combined with seeking and reading} {
lappend x [chan tell $f]
chan seek $f 0 end
lappend x [chan tell $f]
+} -cleanup {
chan close $f
- set x
-} {0 3 2 12 30}
-test chan-io-34.19 {Tcl_Tell combined with opening in append mode} {
+} -result {0 3 2 12 30}
+test chan-io-34.19 {Tcl_Tell combined with opening in append mode} -body {
set f [open $path(test3) w]
chan configure $f -translation lf -eofchar {}
chan puts $f "abcdefghijklmnopqrstuvwxyz"
chan puts $f "abcdefghijklmnopqrstuvwxyz"
chan close $f
set f [open $path(test3) a]
- set c [chan tell $f]
+ chan tell $f
+} -cleanup {
chan close $f
- set c
-} 54
-test chan-io-34.20 {Tcl_Tell combined with writing} {
- set f [open $path(test3) w]
+} -result 54
+test chan-io-34.20 {Tcl_Tell combined with writing} -setup {
set l ""
+} -body {
+ set f [open $path(test3) w]
chan seek $f 29 start
lappend l [chan tell $f]
chan puts -nonewline $f a
@@ -4375,14 +4495,15 @@ test chan-io-34.20 {Tcl_Tell combined with writing} {
lappend l [chan tell $f]
chan seek $f 407 end
lappend l [chan tell $f]
+} -cleanup {
chan close $f
- set l
-} {29 39 40 447}
-test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} {
+} -result {29 39 40 447}
+test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} -setup {
file delete $path(test3)
+ set l ""
+} -constraints {largefileSupport} -body {
set f [open $path(test3) w]
chan configure $f -encoding binary
- set l ""
lappend l [chan tell $f]
chan puts -nonewline $f abcdef
lappend l [chan tell $f]
@@ -4398,13 +4519,13 @@ test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} {
# truncate...
chan close [open $path(test3) w]
lappend l [file size $f]
- set l
-} {0 6 6 4294967296 4294967302 4294967302 0}
+} -result {0 6 6 4294967296 4294967302 4294967302 0}
# Test Tcl_Eof
-test chan-io-35.1 {Tcl_Eof} {
+test chan-io-35.1 {Tcl_Eof} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan puts $f hello
chan puts $f hello
@@ -4419,16 +4540,17 @@ test chan-io-35.1 {Tcl_Eof} {
chan gets $f
lappend x [chan eof $f]
lappend x [chan eof $f]
+} -cleanup {
chan close $f
- set x
-} {0 0 0 0 1 1}
-test chan-io-35.2 {Tcl_Eof with pipe} {stdio openpipe} {
+} -result {0 0 0 0 1 1}
+test chan-io-35.2 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup {
file delete $path(pipe)
+} -body {
set f1 [open $path(pipe) w]
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
@@ -4437,16 +4559,17 @@ test chan-io-35.2 {Tcl_Eof with pipe} {stdio openpipe} {
lappend x [chan eof $f1]
chan gets $f1
lappend x [chan eof $f1]
+} -cleanup {
chan close $f1
- set x
-} {0 0 0 1}
-test chan-io-35.3 {Tcl_Eof with pipe} {stdio openpipe} {
+} -result {0 0 0 1}
+test chan-io-35.3 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup {
file delete $path(pipe)
+} -body {
set f1 [open $path(pipe) w]
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
@@ -4459,37 +4582,39 @@ test chan-io-35.3 {Tcl_Eof with pipe} {stdio openpipe} {
lappend x [chan eof $f1]
chan gets $f1
lappend x [chan eof $f1]
+} -cleanup {
chan close $f1
- set x
-} {0 0 0 1 1 1}
-test chan-io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} {
+} -result {0 0 0 1 1 1}
+test chan-io-35.4 {Tcl_Eof, eof detection on nonblocking file} -setup {
file delete $path(test1)
- set f [open $path(test1) w]
- chan close $f
+ set l ""
+} -constraints {nonBlockFiles} -body {
+ chan close [open $path(test1) w]
set f [open $path(test1) r]
chan configure $f -blocking off
- set l ""
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {{} 1}
-test chan-io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio openpipe} {
+} -result {{} 1}
+test chan-io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} -setup {
file delete $path(pipe)
+ set l ""
+} -constraints {stdio openpipe} -body {
set f [open $path(pipe) w]
chan puts $f {
exit
}
chan close $f
- set f [open "|[list [interpreter] $path(pipe)]" r]
- set l ""
+ set f [openpipe r $path(pipe)]
lappend l [chan gets $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {{} 1}
-test chan-io-35.6 {Tcl_Eof, eof char, lf write, auto read} {
+} -result {{} 1}
+test chan-io-35.6 {Tcl_Eof, eof char, lf write, auto read} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -eofchar \x1a
chan puts $f abc\ndef
@@ -4497,13 +4622,13 @@ test chan-io-35.6 {Tcl_Eof, eof char, lf write, auto read} {
set s [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1a
- set l [string length [chan read $f]]
- set e [chan eof $f]
+ list $s [string length [chan read $f]] [chan eof $f]
+} -cleanup {
chan close $f
- list $s $l $e
-} {9 8 1}
-test chan-io-35.7 {Tcl_Eof, eof char, lf write, lf read} {
+} -result {9 8 1}
+test chan-io-35.7 {Tcl_Eof, eof char, lf write, lf read} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -eofchar \x1a
chan puts $f abc\ndef
@@ -4511,13 +4636,13 @@ test chan-io-35.7 {Tcl_Eof, eof char, lf write, lf read} {
set s [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation lf -eofchar \x1a
- set l [string length [chan read $f]]
- set e [chan eof $f]
+ list $s [string length [chan read $f]] [chan eof $f]
+} -cleanup {
chan close $f
- list $s $l $e
-} {9 8 1}
-test chan-io-35.8 {Tcl_Eof, eof char, cr write, auto read} {
+} -result {9 8 1}
+test chan-io-35.8 {Tcl_Eof, eof char, cr write, auto read} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation cr -eofchar \x1a
chan puts $f abc\ndef
@@ -4525,13 +4650,13 @@ test chan-io-35.8 {Tcl_Eof, eof char, cr write, auto read} {
set s [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1a
- set l [string length [chan read $f]]
- set e [chan eof $f]
+ list $s [string length [chan read $f]] [chan eof $f]
+} -cleanup {
chan close $f
- list $s $l $e
-} {9 8 1}
-test chan-io-35.9 {Tcl_Eof, eof char, cr write, cr read} {
+} -result {9 8 1}
+test chan-io-35.9 {Tcl_Eof, eof char, cr write, cr read} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation cr -eofchar \x1a
chan puts $f abc\ndef
@@ -4539,13 +4664,13 @@ test chan-io-35.9 {Tcl_Eof, eof char, cr write, cr read} {
set s [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation cr -eofchar \x1a
- set l [string length [chan read $f]]
- set e [chan eof $f]
+ list $s [string length [chan read $f]] [chan eof $f]
+} -cleanup {
chan close $f
- list $s $l $e
-} {9 8 1}
-test chan-io-35.10 {Tcl_Eof, eof char, crlf write, auto read} {
+} -result {9 8 1}
+test chan-io-35.10 {Tcl_Eof, eof char, crlf write, auto read} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf -eofchar \x1a
chan puts $f abc\ndef
@@ -4553,13 +4678,13 @@ test chan-io-35.10 {Tcl_Eof, eof char, crlf write, auto read} {
set s [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1a
- set l [string length [chan read $f]]
- set e [chan eof $f]
+ list $s [string length [chan read $f]] [chan eof $f]
+} -cleanup {
chan close $f
- list $s $l $e
-} {11 8 1}
-test chan-io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} {
+} -result {11 8 1}
+test chan-io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf -eofchar \x1a
chan puts $f abc\ndef
@@ -4567,112 +4692,106 @@ test chan-io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} {
set s [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation crlf -eofchar \x1a
- set l [string length [chan read $f]]
- set e [chan eof $f]
+ list $s [string length [chan read $f]] [chan eof $f]
+} -cleanup {
chan close $f
- list $s $l $e
-} {11 8 1}
-test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} {
+} -result {11 8 1}
+test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -eofchar {}
- set i [format abc\ndef\n%cqrs\nuvw 26]
- chan puts $f $i
+ chan puts $f [format abc\ndef\n%cqrs\nuvw 26]
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1a
- set l [string length [chan read $f]]
- set e [chan eof $f]
+ list $c [string length [chan read $f]] [chan eof $f]
+} -cleanup {
chan close $f
- list $c $l $e
-} {17 8 1}
-test chan-io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} {
+} -result {17 8 1}
+test chan-io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -eofchar {}
- set i [format abc\ndef\n%cqrs\nuvw 26]
- chan puts $f $i
+ chan puts $f [format abc\ndef\n%cqrs\nuvw 26]
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation lf -eofchar \x1a
- set l [string length [chan read $f]]
- set e [chan eof $f]
+ list $c [string length [chan read $f]] [chan eof $f]
+} -cleanup {
chan close $f
- list $c $l $e
-} {17 8 1}
-test chan-io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} {
+} -result {17 8 1}
+test chan-io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation cr -eofchar {}
- set i [format abc\ndef\n%cqrs\nuvw 26]
- chan puts $f $i
+ chan puts $f [format abc\ndef\n%cqrs\nuvw 26]
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1a
- set l [string length [chan read $f]]
- set e [chan eof $f]
+ list $c [string length [chan read $f]] [chan eof $f]
+} -cleanup {
chan close $f
- list $c $l $e
-} {17 8 1}
-test chan-io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} {
+} -result {17 8 1}
+test chan-io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation cr -eofchar {}
- set i [format abc\ndef\n%cqrs\nuvw 26]
- chan puts $f $i
+ chan puts $f [format abc\ndef\n%cqrs\nuvw 26]
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation cr -eofchar \x1a
- set l [string length [chan read $f]]
- set e [chan eof $f]
+ list $c [string length [chan read $f]] [chan eof $f]
+} -cleanup {
chan close $f
- list $c $l $e
-} {17 8 1}
-test chan-io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} {
+} -result {17 8 1}
+test chan-io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf -eofchar {}
- set i [format abc\ndef\n%cqrs\nuvw 26]
- chan puts $f $i
+ chan puts $f [format abc\ndef\n%cqrs\nuvw 26]
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1a
- set l [string length [chan read $f]]
- set e [chan eof $f]
+ list $c [string length [chan read $f]] [chan eof $f]
+} -cleanup {
chan close $f
- list $c $l $e
-} {21 8 1}
-test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} {
+} -result {21 8 1}
+test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf -eofchar {}
- set i [format abc\ndef\n%cqrs\nuvw 26]
- chan puts $f $i
+ chan puts $f [format abc\ndef\n%cqrs\nuvw 26]
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation crlf -eofchar \x1a
- set l [string length [chan read $f]]
- set e [chan eof $f]
+ list $c [string length [chan read $f]] [chan eof $f]
+} -cleanup {
chan close $f
- list $c $l $e
-} {21 8 1}
+} -result {21 8 1}
# Test Tcl_InputBlocked
-test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} {
- set f1 [open "|[list [interpreter]]" r+]
+test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} -setup {
+ set x ""
+} -constraints {stdio openpipe} -body {
+ set f1 [openpipe]
chan puts $f1 {chan puts hello_from_pipe}
chan flush $f1
chan gets $f1
chan configure $f1 -blocking off -buffering full
chan puts $f1 {chan puts hello}
- set x ""
lappend x [chan gets $f1]
lappend x [chan blocked $f1]
chan flush $f1
@@ -4681,133 +4800,135 @@ test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} {
lappend x [chan blocked $f1]
lappend x [chan gets $f1]
lappend x [chan blocked $f1]
+} -cleanup {
chan close $f1
- set x
-} {{} 1 hello 0 {} 1}
-test chan-io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio openpipe} {
- set f1 [open "|[list [interpreter]]" r+]
+} -result {{} 1 hello 0 {} 1}
+test chan-io-36.2 {Tcl_InputBlocked on blocking pipe} -setup {
+ set x ""
+} -constraints {stdio openpipe} -body {
+ set f1 [openpipe]
chan configure $f1 -buffering line
chan puts $f1 {chan puts hello_from_pipe}
- set x ""
lappend x [chan gets $f1]
lappend x [chan blocked $f1]
chan puts $f1 {exit}
lappend x [chan gets $f1]
lappend x [chan blocked $f1]
lappend x [chan eof $f1]
+} -cleanup {
chan close $f1
- set x
-} {hello_from_pipe 0 {} 0 1}
-test chan-io-36.3 {Tcl_InputBlocked vs files, short read} {
+} -result {hello_from_pipe 0 {} 0 1}
+test chan-io-36.3 {Tcl_InputBlocked vs files, short read} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan puts $f abcdefghijklmnop
chan close $f
set f [open $path(test1) r]
- set l ""
lappend l [chan blocked $f]
lappend l [chan read $f 3]
lappend l [chan blocked $f]
lappend l [chan read -nonewline $f]
lappend l [chan blocked $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {0 abc 0 defghijklmnop 0 1}
-test chan-io-36.4 {Tcl_InputBlocked vs files, event driven read} {fileevent} {
- 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}
- }
+} -result {0 abc 0 defghijklmnop 0 1}
+test chan-io-36.4 {Tcl_InputBlocked vs files, event driven read} -setup {
file delete $path(test1)
+ set l ""
+ variable x
+} -constraints {fileevent} -body {
set f [open $path(test1) w]
chan puts $f abcdefghijklmnop
chan close $f
set f [open $path(test1) r]
- set l ""
- chan event $f readable [namespace code [list in $f]]
- variable x
+ 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]
- set l
-} {abc def ghi jkl mno {p
+ return $l
+} -result {abc def ghi jkl mno {p
} eof}
-test chan-io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} {
+test chan-io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} -setup {
file delete $path(test1)
+ set l ""
+} -constraints {nonBlockFiles} -body {
set f [open $path(test1) w]
chan puts $f abcdefghijklmnop
chan close $f
set f [open $path(test1) r]
chan configure $f -blocking off
- set l ""
lappend l [chan blocked $f]
lappend l [chan read $f 3]
lappend l [chan blocked $f]
lappend l [chan read -nonewline $f]
lappend l [chan blocked $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} {0 abc 0 defghijklmnop 0 1}
-test chan-io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles fileevent} {
- 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}
- }
+} -result {0 abc 0 defghijklmnop 0 1}
+test chan-io-36.6 {Tcl_InputBlocked vs files, event driven read} -setup {
file delete $path(test1)
+ set l ""
+ variable x
+} -constraints {nonBlockFiles fileevent} -body {
set f [open $path(test1) w]
chan puts $f abcdefghijklmnop
chan close $f
set f [open $path(test1) r]
chan configure $f -blocking off
- set l ""
- chan event $f readable [namespace code [list in $f]]
- variable x
+ 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]
- set l
-} {abc def ghi jkl mno {p
+ return $l
+} -result {abc def ghi jkl mno {p
} eof}
# Test Tcl_InputBuffered
-test chan-io-37.1 {Tcl_InputBuffered} {testchannel} {
+test chan-io-37.1 {Tcl_InputBuffered} -setup {
+ set l ""
+} -constraints {testchannel} -body {
set f [open $path(longfile) r]
chan configure $f -buffersize 4096
chan read $f 3
- set l ""
lappend l [testchannel inputbuffered $f]
lappend l [chan tell $f]
+} -cleanup {
chan close $f
- set l
-} {4093 3}
-test chan-io-37.2 {Tcl_InputBuffered, test input flushing on seek} {testchannel} {
+} -result {4093 3}
+test chan-io-37.2 {Tcl_InputBuffered, test input flushing on seek} -setup {
+ set l ""
+} -constraints {testchannel} -body {
set f [open $path(longfile) r]
chan configure $f -buffersize 4096
chan read $f 3
- set l ""
lappend l [testchannel inputbuffered $f]
lappend l [chan tell $f]
chan seek $f 0 current
lappend l [testchannel inputbuffered $f]
lappend l [chan tell $f]
+} -cleanup {
chan close $f
- set l
-} {4093 3 0 3}
+} -result {4093 3 0 3}
# Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize
-test chan-io-38.1 {Tcl_GetChannelBufferSize, default buffer size} {
+test chan-io-38.1 {Tcl_GetChannelBufferSize, default buffer size} -body {
set f [open $path(longfile) r]
- set s [chan configure $f -buffersize]
+ chan configure $f -buffersize
+} -cleanup {
chan close $f
- set s
-} 4096
-test chan-io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} {
- set f [open $path(longfile) r]
+} -result 4096
+test chan-io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} -setup {
set l ""
+} -body {
+ set f [open $path(longfile) r]
lappend l [chan configure $f -buffersize]
chan configure $f -buffersize 10000
lappend l [chan configure $f -buffersize]
@@ -4821,9 +4942,9 @@ test chan-io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} {
lappend l [chan configure $f -buffersize]
chan configure $f -buffersize 10000000
lappend l [chan configure $f -buffersize]
+} -cleanup {
chan close $f
- set l
-} {4096 10000 1 1 1 100000 1048576}
+} -result {4096 10000 1 1 1 100000 1048576}
test chan-io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} {
# This test crashes the interp if Bug #427196 is not fixed
set chan [open [info script] r]
@@ -4836,35 +4957,39 @@ test chan-io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads}
# Test Tcl_SetChannelOption, Tcl_GetChannelOption
-test chan-io-39.1 {Tcl_GetChannelOption} {
+test chan-io-39.1 {Tcl_GetChannelOption} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
- set x [chan configure $f1 -blocking]
+ chan configure $f1 -blocking
+} -cleanup {
chan close $f1
- set x
-} 1
+} -result 1
#
# Test 17.2 was removed.
#
-test chan-io-39.2 {Tcl_GetChannelOption} {
+test chan-io-39.2 {Tcl_GetChannelOption} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
- set x [chan configure $f1 -buffering]
+ chan configure $f1 -buffering
+} -cleanup {
chan close $f1
- set x
-} full
-test chan-io-39.3 {Tcl_GetChannelOption} {
+} -result full
+test chan-io-39.3 {Tcl_GetChannelOption} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
chan configure $f1 -buffering line
- set x [chan configure $f1 -buffering]
+ chan configure $f1 -buffering
+} -cleanup {
chan close $f1
- set x
-} line
-test chan-io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} {
+} -result line
+test chan-io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} -setup {
file delete $path(test1)
- set f1 [open $path(test1) w]
set l ""
+} -body {
+ set f1 [open $path(test1) w]
lappend l [chan configure $f1 -buffering]
chan configure $f1 -buffering line
lappend l [chan configure $f1 -buffering]
@@ -4874,47 +4999,51 @@ test chan-io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} {
lappend l [chan configure $f1 -buffering]
chan configure $f1 -buffering full
lappend l [chan configure $f1 -buffering]
+} -cleanup {
chan close $f1
- set l
-} {full line none line full}
-test chan-io-39.5 {Tcl_GetChannelOption, invariance} {
+} -result {full line none line full}
+test chan-io-39.5 {Tcl_GetChannelOption, invariance} -setup {
file delete $path(test1)
- set f1 [open $path(test1) w]
set l ""
+} -body {
+ set f1 [open $path(test1) w]
lappend l [chan configure $f1 -buffering]
lappend l [list [catch {chan configure $f1 -buffering green} msg] $msg]
lappend l [chan configure $f1 -buffering]
+} -cleanup {
chan close $f1
- set l
-} {full {1 {bad value for -buffering: must be one of full, line, or none}} full}
-test chan-io-39.6 {Tcl_SetChannelOption, multiple options} {
+} -result {full {1 {bad value for -buffering: must be one of full, line, or none}} full}
+test chan-io-39.6 {Tcl_SetChannelOption, multiple options} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf -buffering line
chan puts $f1 hello
chan puts $f1 bye
- set x [file size $path(test1)]
+ file size $path(test1)
+} -cleanup {
chan close $f1
- set x
-} 10
-test chan-io-39.7 {Tcl_SetChannelOption, buffering, translation} {
+} -result 10
+test chan-io-39.7 {Tcl_SetChannelOption, buffering, translation} -setup {
file delete $path(test1)
+ set x ""
+} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
chan puts $f1 hello
chan puts $f1 bye
- set x ""
chan configure $f1 -buffering line
lappend x [file size $path(test1)]
chan puts $f1 really_bye
lappend x [file size $path(test1)]
+} -cleanup {
chan close $f1
- set x
-} {0 21}
-test chan-io-39.8 {Tcl_SetChannelOption, different buffering options} {
+} -result {0 21}
+test chan-io-39.8 {Tcl_SetChannelOption, different buffering options} -setup {
file delete $path(test1)
- set f1 [open $path(test1) w]
set l ""
+} -body {
+ set f1 [open $path(test1) w]
chan configure $f1 -translation lf -buffering none -eofchar {}
chan puts -nonewline $f1 hello
lappend l [file size $path(test1)]
@@ -4929,14 +5058,14 @@ test chan-io-39.8 {Tcl_SetChannelOption, different buffering options} {
lappend l [file size $path(test1)]
chan close $f1
lappend l [file size $path(test1)]
- set l
-} {5 10 10 10 20 20}
-test chan-io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} {
+} -result {5 10 10 10 20 20}
+test chan-io-39.9 {Tcl_SetChannelOption, blocking mode} -setup {
file delete $path(test1)
+ set x ""
+} -constraints {nonBlockFiles} -body {
set f1 [open $path(test1) w]
chan close $f1
set f1 [open $path(test1) r]
- set x ""
lappend x [chan configure $f1 -blocking]
chan configure $f1 -blocking off
lappend x [chan configure $f1 -blocking]
@@ -4944,11 +5073,13 @@ test chan-io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} {
lappend x [chan read $f1 1000]
lappend x [chan blocked $f1]
lappend x [chan eof $f1]
+} -cleanup {
chan close $f1
- set x
-} {1 0 {} {} 0 1}
-test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} {
+} -result {1 0 {} {} 0 1}
+test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} -setup {
file delete $path(pipe)
+ set x ""
+} -constraints {stdio openpipe} -body {
set f1 [open $path(pipe) w]
chan puts $f1 {
chan gets stdin
@@ -4957,8 +5088,7 @@ test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} {
chan gets stdin
}
chan close $f1
- set x ""
- 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]
@@ -4980,71 +5110,78 @@ test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} {
lappend x [chan eof $f1]
lappend x [chan gets $f1]
lappend x [chan eof $f1]
+} -cleanup {
chan close $f1
- set x
-} {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1}
-test chan-io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size clipped to lower bound} {
+} -result {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1}
+test chan-io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size clipped to lower bound} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -buffersize -10
- set x [chan configure $f -buffersize]
+ chan configure $f -buffersize
+} -cleanup {
chan close $f
- set x
-} 1
-test chan-io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size clipped to upper bound} {
+} -result 1
+test chan-io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size clipped to upper bound} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -buffersize 10000000
- set x [chan configure $f -buffersize]
+ chan configure $f -buffersize
+} -cleanup {
chan close $f
- set x
-} 1048576
-test chan-io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} {
+} -result 1048576
+test chan-io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -buffersize 40000
- set x [chan configure $f -buffersize]
+ chan configure $f -buffersize
+} -cleanup {
chan close $f
- set x
-} 40000
-test chan-io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
+} -result 40000
+test chan-io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -encoding {}
chan puts -nonewline $f \xe7\x89\xa6
chan close $f
set f [open $path(test1) r]
chan configure $f -encoding utf-8
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} \u7266
-test chan-io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
+} -result \u7266
+test chan-io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup {
file delete $path(test1)
+} -body {
set f [open $path(test1) w]
chan configure $f -encoding binary
chan puts -nonewline $f \xe7\x89\xa6
chan close $f
set f [open $path(test1) r]
chan configure $f -encoding utf-8
- set x [chan read $f]
+ chan read $f
+} -cleanup {
chan close $f
- set x
-} \u7266
-test chan-io-39.16 {Tcl_SetChannelOption: -encoding, errors} {
+} -result \u7266
+test chan-io-39.16 {Tcl_SetChannelOption: -encoding, errors} -setup {
file delete $path(test1)
set f [open $path(test1) w]
- set result [list [catch {chan configure $f -encoding foobar} msg] $msg]
+} -body {
+ chan configure $f -encoding foobar
+} -returnCodes error -cleanup {
chan close $f
- set result
-} {1 {unknown encoding "foobar"}}
-test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio openpipe fileevent} {
- set f [open "|[list [interpreter] $path(cat)]" r+]
+} -result {unknown encoding "foobar"}
+test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} -setup {
+ variable x {}
+} -constraints {stdio openpipe fileevent} -body {
+ set f [openpipe r+ $path(cat)]
chan configure $f -encoding binary
chan puts -nonewline $f "\xe7"
chan flush $f
chan configure $f -encoding utf-8 -blocking 0
- variable x {}
chan event $f readable [namespace code { lappend x [chan read $f] }]
vwait [namespace which -variable x]
after 300 [namespace code { lappend x timeout }]
@@ -5057,105 +5194,113 @@ test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_
vwait [namespace which -variable x]
after 300 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
+ return $x
+} -cleanup {
chan close $f
- set x
-} "{} timeout {} timeout \xe7 timeout"
+} -result "{} timeout {} timeout \xe7 timeout"
test chan-io-39.18 {Tcl_SetChannelOption, setting read mode independently} \
- {socket} {
+ -constraints {socket} -body {
proc accept {s a p} {chan close $s}
set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
set port [lindex [chan configure $s1 -sockname] 2]
set s2 [socket 127.0.0.1 $port]
update
chan configure $s2 -translation {auto lf}
- set modes [chan configure $s2 -translation]
+ chan configure $s2 -translation
+} -cleanup {
chan close $s1
chan close $s2
- set modes
-} {auto lf}
+} -result {auto lf}
test chan-io-39.19 {Tcl_SetChannelOption, setting read mode independently} \
- {socket} {
+ -constraints {socket} -body {
proc accept {s a p} {chan close $s}
set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
set port [lindex [chan configure $s1 -sockname] 2]
set s2 [socket 127.0.0.1 $port]
update
chan configure $s2 -translation {auto crlf}
- set modes [chan configure $s2 -translation]
+ chan configure $s2 -translation
+} -cleanup {
chan close $s1
chan close $s2
- set modes
-} {auto crlf}
+} -result {auto crlf}
test chan-io-39.20 {Tcl_SetChannelOption, setting read mode independently} \
- {socket} {
+ -constraints {socket} -body {
proc accept {s a p} {chan close $s}
set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
set port [lindex [chan configure $s1 -sockname] 2]
set s2 [socket 127.0.0.1 $port]
update
chan configure $s2 -translation {auto cr}
- set modes [chan configure $s2 -translation]
+ chan configure $s2 -translation
+} -cleanup {
chan close $s1
chan close $s2
- set modes
-} {auto cr}
+} -result {auto cr}
test chan-io-39.21 {Tcl_SetChannelOption, setting read mode independently} \
- {socket} {
+ -constraints {socket} -body {
proc accept {s a p} {chan close $s}
set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
set port [lindex [chan configure $s1 -sockname] 2]
set s2 [socket 127.0.0.1 $port]
update
chan configure $s2 -translation {auto auto}
- set modes [chan configure $s2 -translation]
+ chan configure $s2 -translation
+} -cleanup {
chan close $s1
chan close $s2
- set modes
-} {auto crlf}
-test chan-io-39.22 {Tcl_SetChannelOption, invariance} {unix} {
+} -result {auto crlf}
+test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup {
file delete $path(test1)
- set f1 [open $path(test1) w+]
set l ""
+} -constraints {unix} -body {
+ set f1 [open $path(test1) w+]
lappend l [chan configure $f1 -eofchar]
chan configure $f1 -eofchar {ON GO}
lappend l [chan configure $f1 -eofchar]
chan configure $f1 -eofchar D
lappend l [chan configure $f1 -eofchar]
+} -cleanup {
chan close $f1
- set l
-} {{{} {}} {O G} {D D}}
-test chan-io-39.22a {Tcl_SetChannelOption, invariance} {
+} -result {{{} {}} {O G} {D D}}
+test chan-io-39.22a {Tcl_SetChannelOption, invariance} -setup {
file delete $path(test1)
- set f1 [open $path(test1) w+]
set l [list]
+} -body {
+ set f1 [open $path(test1) w+]
chan configure $f1 -eofchar {ON GO}
lappend l [chan configure $f1 -eofchar]
chan configure $f1 -eofchar D
lappend l [chan configure $f1 -eofchar]
lappend l [list [catch {chan configure $f1 -eofchar {1 2 3}} msg] $msg]
+} -cleanup {
chan close $f1
- set l
-} {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}}
-test chan-io-39.23 {Tcl_GetChannelOption, server socket is not readable or
- writeable, it should still have valid -eofchar and -translation options } {
+} -result {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}}
+test chan-io-39.23 {Tcl_GetChannelOption, server socket is not readable or\
+ writeable, it should still have valid -eofchar and -translation options} -setup {
set l [list]
+} -body {
set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
- lappend l [chan configure $sock -eofchar] [chan configure $sock -translation]
+ lappend l [chan configure $sock -eofchar] \
+ [chan configure $sock -translation]
+} -cleanup {
chan close $sock
- set l
-} {{{}} auto}
-test chan-io-39.24 {Tcl_SetChannelOption, server socket is not readable or
- writable so we can't change -eofchar or -translation } {
+} -result {{{}} auto}
+test chan-io-39.24 {Tcl_SetChannelOption, server socket is not readable or\
+ writable so we can't change -eofchar or -translation} -setup {
set l [list]
+} -body {
set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
chan configure $sock -eofchar D -translation lf
- lappend l [chan configure $sock -eofchar] [chan configure $sock -translation]
+ lappend l [chan configure $sock -eofchar] \
+ [chan configure $sock -translation]
+} -cleanup {
chan close $sock
- set l
-} {{{}} auto}
+} -result {{{}} auto}
-test chan-io-40.1 {POSIX open access modes: RDWR} {
+test chan-io-40.1 {POSIX open access modes: RDWR} -setup {
file delete $path(test3)
+} -body {
set f [open $path(test3) w]
chan puts $f xyzzy
chan close $f
@@ -5166,11 +5311,12 @@ test chan-io-40.1 {POSIX open access modes: RDWR} {
chan close $f
set f [open $path(test3) r]
lappend x [chan gets $f]
+} -cleanup {
chan close $f
- set x
-} {zzy abzzy}
-test chan-io-40.2 {POSIX open access modes: CREAT} {unix} {
+} -result {zzy abzzy}
+test chan-io-40.2 {POSIX open access modes: CREAT} -setup {
file delete $path(test3)
+} -constraints {unix} -body {
set f [open $path(test3) {WRONLY CREAT} 0600]
file stat $path(test3) stats
set x [format "0%o" [expr $stats(mode)&0o777]]
@@ -5178,19 +5324,20 @@ test chan-io-40.2 {POSIX open access modes: CREAT} {unix} {
chan close $f
set f [open $path(test3) r]
lappend x [chan gets $f]
+} -cleanup {
chan close $f
- set x
-} {0600 {line 1}}
-test chan-io-40.3 {POSIX open access modes: CREAT} {unix umask} {
- # This test only works if your umask is 2, like ouster's.
+} -result {0600 {line 1}}
+test chan-io-40.3 {POSIX open access modes: CREAT} -setup {
file delete $path(test3)
- set f [open $path(test3) {WRONLY CREAT}]
- chan close $f
+} -constraints {unix umask} -body {
+ # This test only works if your umask is 2, like ouster's.
+ chan close [open $path(test3) {WRONLY CREAT}]
file stat $path(test3) stats
format "0%o" [expr $stats(mode)&0o777]
-} [format %04o [expr {0o666 & ~ $umaskValue}]]
-test chan-io-40.4 {POSIX open access modes: CREAT} {
+} -result [format %04o [expr {0o666 & ~ $umaskValue}]]
+test chan-io-40.4 {POSIX open access modes: CREAT} -setup {
file delete $path(test3)
+} -body {
set f [open $path(test3) w]
chan configure $f -eofchar {}
chan puts $f xyzzy
@@ -5200,12 +5347,14 @@ test chan-io-40.4 {POSIX open access modes: CREAT} {
chan puts -nonewline $f "ab"
chan close $f
set f [open $path(test3) r]
- set x [chan gets $f]
+ chan gets $f
+} -cleanup {
chan close $f
- set x
-} abzzy
-test chan-io-40.5 {POSIX open access modes: APPEND} {
+} -result abzzy
+test chan-io-40.5 {POSIX open access modes: APPEND} -setup {
file delete $path(test3)
+ set x ""
+} -body {
set f [open $path(test3) w]
chan configure $f -translation lf -eofchar {}
chan puts $f xyzzy
@@ -5218,30 +5367,32 @@ test chan-io-40.5 {POSIX open access modes: APPEND} {
chan close $f
set f [open $path(test3) r]
chan configure $f -translation lf
- set x ""
chan seek $f 6 current
lappend x [chan gets $f]
lappend x [chan gets $f]
+} -cleanup {
chan close $f
- set x
-} {{new line} abc}
-test chan-io-40.6 {POSIX open access modes: EXCL} -match regexp -body {
+} -result {{new line} abc}
+test chan-io-40.6 {POSIX open access modes: EXCL} -match regexp -setup {
file delete $path(test3)
+} -body {
set f [open $path(test3) w]
chan puts $f xyzzy
chan close $f
open $path(test3) {WRONLY CREAT EXCL}
} -returnCodes error -result {(?i)couldn't open ".*test3": file (already )?exists}
-test chan-io-40.7 {POSIX open access modes: EXCL} {
+test chan-io-40.7 {POSIX open access modes: EXCL} -setup {
file delete $path(test3)
+} -body {
set f [open $path(test3) {WRONLY CREAT EXCL}]
chan configure $f -eofchar {}
chan puts $f "A test line"
chan close $f
viewFile test3
-} {A test line}
-test chan-io-40.8 {POSIX open access modes: TRUNC} {
+} -result {A test line}
+test chan-io-40.8 {POSIX open access modes: TRUNC} -setup {
file delete $path(test3)
+} -body {
set f [open $path(test3) w]
chan puts $f xyzzy
chan close $f
@@ -5249,32 +5400,31 @@ test chan-io-40.8 {POSIX open access modes: TRUNC} {
chan puts $f abc
chan close $f
set f [open $path(test3) r]
- set x [chan gets $f]
+ chan gets $f
+} -cleanup {
chan close $f
- set x
-} abc
-test chan-io-40.9 {POSIX open access modes: NONBLOCK} {nonPortable unix} {
+} -result abc
+test chan-io-40.9 {POSIX open access modes: NONBLOCK} -setup {
file delete $path(test3)
+} -constraints {nonPortable unix} -body {
set f [open $path(test3) {WRONLY NONBLOCK CREAT}]
chan puts $f "NONBLOCK test"
chan close $f
set f [open $path(test3) r]
- set x [chan gets $f]
+ chan gets $f
+} -cleanup {
chan close $f
- set x
-} {NONBLOCK test}
-test chan-io-40.10 {POSIX open access modes: RDONLY} {
+} -result {NONBLOCK test}
+test chan-io-40.10 {POSIX open access modes: RDONLY} -body {
set f [open $path(test1) w]
chan puts $f "two lines: this one"
chan puts $f "and this"
chan close $f
set f [open $path(test1) RDONLY]
- set x [list [chan gets $f] [catch {chan puts $f Test} msg] $msg]
+ list [chan gets $f] [catch {chan puts $f Test} msg] $msg
+} -cleanup {
chan close $f
- string compare [string tolower $x] \
- [list {two lines: this one} 1 \
- [format "channel \"%s\" wasn't opened for writing" $f]]
-} 0
+} -match glob -result {{two lines: this one} 1 {channel "*" wasn't opened for writing}}
test chan-io-40.11 {POSIX open access modes: RDONLY} -match regexp -body {
file delete $path(test3)
open $path(test3) RDONLY
@@ -5283,7 +5433,7 @@ test chan-io-40.12 {POSIX open access modes: WRONLY} -match regexp -body {
file delete $path(test3)
open $path(test3) WRONLY
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
-test chan-io-40.13 {POSIX open access modes: WRONLY} {
+test chan-io-40.13 {POSIX open access modes: WRONLY} -body {
makeFile xyzzy test3
set f [open $path(test3) WRONLY]
chan configure $f -eofchar {}
@@ -5292,9 +5442,7 @@ test chan-io-40.13 {POSIX open access modes: WRONLY} {
set x [list [catch {chan gets $f} msg] $msg]
chan close $f
lappend x [viewFile test3]
- string compare [string tolower $x] \
- [list 1 "channel \"$f\" wasn't opened for reading" abzzy]
-} 0
+} -match glob -result {1 {channel "*" wasn't opened for reading} abzzy}
test chan-io-40.14 {POSIX open access modes: RDWR} -match regexp -body {
file delete $path(test3)
open $path(test3) RDWR
@@ -5315,29 +5463,30 @@ test chan-io-40.16 {tilde substitution in open} -constraints makeFileInHome -set
} -cleanup {
removeFile _test_ ~
} -result 1
-test chan-io-40.17 {tilde substitution in open} {
+test chan-io-40.17 {tilde substitution in open} -setup {
set home $::env(HOME)
+} -body {
unset ::env(HOME)
- set x [list [catch {open ~/foo} msg] $msg]
+ open ~/foo
+} -returnCodes error -cleanup {
set ::env(HOME) $home
- set x
-} {1 {couldn't find HOME environment variable to expand path}}
+} -result {couldn't find HOME environment variable to expand path}
-test chan-io-41.1 {Tcl_FileeventCmd: errors} {fileevent} {
- list [catch {chan event foo} msg] $msg
-} {1 {wrong # args: should be "chan event channelId event ?script?"}}
-test chan-io-41.2 {Tcl_FileeventCmd: errors} {fileevent} {
- list [catch {chan event foo bar baz q} msg] $msg
-} {1 {wrong # args: should be "chan event channelId event ?script?"}}
-test chan-io-41.3 {Tcl_FileeventCmd: errors} {fileevent} {
- list [catch {chan event gorp readable} msg] $msg
-} {1 {can not find channel named "gorp"}}
-test chan-io-41.4 {Tcl_FileeventCmd: errors} {fileevent} {
- list [catch {chan event gorp writable} msg] $msg
-} {1 {can not find channel named "gorp"}}
-test chan-io-41.5 {Tcl_FileeventCmd: errors} {fileevent} {
- list [catch {chan event gorp who-knows} msg] $msg
-} {1 {bad event name "who-knows": must be readable or writable}}
+test chan-io-41.1 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
+ chan event foo
+} -returnCodes error -result {wrong # args: should be "chan event channelId event ?script?"}
+test chan-io-41.2 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
+ chan event foo bar baz q
+} -returnCodes error -result {wrong # args: should be "chan event channelId event ?script?"}
+test chan-io-41.3 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
+ chan event gorp readable
+} -returnCodes error -result {can not find channel named "gorp"}
+test chan-io-41.4 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
+ chan event gorp writable
+} -returnCodes error -result {can not find channel named "gorp"}
+test chan-io-41.5 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
+ chan event gorp who-knows
+} -returnCodes error -result {bad event name "who-knows": must be readable or writable}
#
# Test chan event on a file
@@ -5372,7 +5521,6 @@ test chan-io-42.3 {Tcl_FileeventCmd: replacing, with NULL chars in script} {file
lappend result [chan event $f readable]
} {13 11 12 {}}
-
test chan-io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixExecs fileevent} {
set result {}
chan event $f readable "script 1"
@@ -5387,8 +5535,8 @@ test chan-io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixEx
test chan-io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
-} -constraints {stdio unixExecs fileevent openpipe} -body {
set result {}
+} -constraints {stdio unixExecs fileevent openpipe} -body {
lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r]
chan event $f r "chan read f"
chan event $f2 r "chan read f2"
@@ -5415,14 +5563,12 @@ test chan-io-44.1 {FileEventProc procedure: normal read event} -setup {
chan puts $f2 text; chan flush $f2
variable x initial
vwait [namespace which -variable x]
- set x
+ return $x
} -cleanup {
catch {chan close $f2}
catch {chan close $f3}
} -result {text}
-test chan-io-44.2 {FileEventProc procedure: error in read event} -constraints {
- stdio unixExecs fileevent openpipe
-} -setup {
+test chan-io-44.2 {FileEventProc procedure: error in read event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
proc myHandler {msg options} {
@@ -5430,7 +5576,7 @@ test chan-io-44.2 {FileEventProc procedure: error in read event} -constraints {
}
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
-} -body {
+} -constraints {stdio unixExecs fileevent openpipe} -body {
chan event $f2 readable {error bogus}
chan puts $f2 text; chan flush $f2
variable x initial
@@ -5457,14 +5603,12 @@ test chan-io-44.3 {FileEventProc procedure: normal write event} -setup {
vwait [namespace which -variable x]
vwait [namespace which -variable x]
vwait [namespace which -variable x]
- set x
+ return $x
} -cleanup {
catch {chan close $f2}
catch {chan close $f3}
} -result {initial triggered triggered triggered}
-test chan-io-44.4 {FileEventProc procedure: eror in write event} -constraints {
- stdio unixExecs fileevent openpipe
-} -setup {
+test chan-io-44.4 {FileEventProc procedure: eror in write event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
proc myHandler {msg options} {
@@ -5472,7 +5616,7 @@ test chan-io-44.4 {FileEventProc procedure: eror in write event} -constraints {
}
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
-} -body {
+} -constraints {stdio unixExecs fileevent openpipe} -body {
chan event $f2 writable {error bad-write}
variable x initial
vwait [namespace which -variable x]
@@ -5483,7 +5627,7 @@ test chan-io-44.4 {FileEventProc procedure: eror in write event} -constraints {
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
@@ -5510,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
@@ -5519,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 {}
@@ -5595,30 +5741,32 @@ test chan-io-46.3 {Tcl event loop vs multiple interpreters} testfevent {
}
} {0 0 {0 timer}}
-test chan-io-47.1 {chan event vs multiple interpreters} {testfevent fileevent} {
+test chan-io-47.1 {chan event vs multiple interpreters} -setup {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
set f3 [open $path(foo) r]
+ set x {}
+} -constraints {testfevent fileevent} -body {
chan event $f readable {script 1}
testfevent create
testfevent share $f2
testfevent cmd "chan event $f2 readable {script 2}"
chan event $f3 readable {sript 3}
- set x {}
lappend x [chan event $f2 readable]
testfevent delete
lappend x [chan event $f readable] [chan event $f2 readable] \
[chan event $f3 readable]
+} -cleanup {
chan close $f
chan close $f2
chan close $f3
- set x
-} {{} {script 1} {} {sript 3}}
-test chan-io-47.2 {deleting chan event on interpreter delete} {testfevent fileevent} {
+} -result {{} {script 1} {} {sript 3}}
+test chan-io-47.2 {deleting chan event on interpreter delete} -setup {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
set f3 [open $path(foo) r]
set f4 [open $path(foo) r]
+} -constraints {testfevent fileevent} -body {
chan event $f readable {script 1}
testfevent create
testfevent share $f2
@@ -5627,19 +5775,20 @@ test chan-io-47.2 {deleting chan event on interpreter delete} {testfevent fileev
chan event $f3 readable {script 3}"
chan event $f4 readable {script 4}
testfevent delete
- set x [list [chan event $f readable] [chan event $f2 readable] \
- [chan event $f3 readable] [chan event $f4 readable]]
+ list [chan event $f readable] [chan event $f2 readable] \
+ [chan event $f3 readable] [chan event $f4 readable]
+} -cleanup {
chan close $f
chan close $f2
chan close $f3
chan close $f4
- set x
-} {{script 1} {} {} {script 4}}
-test chan-io-47.3 {deleting chan event on interpreter delete} {testfevent fileevent} {
+} -result {{script 1} {} {} {script 4}}
+test chan-io-47.3 {deleting chan event on interpreter delete} -setup {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
set f3 [open $path(foo) r]
set f4 [open $path(foo) r]
+} -constraints {testfevent fileevent} -body {
testfevent create
testfevent share $f3
testfevent share $f4
@@ -5648,56 +5797,56 @@ test chan-io-47.3 {deleting chan event on interpreter delete} {testfevent fileev
testfevent cmd "chan event $f3 readable {script 3}
chan event $f4 readable {script 4}"
testfevent delete
- set x [list [chan event $f readable] [chan event $f2 readable] \
- [chan event $f3 readable] [chan event $f4 readable]]
+ list [chan event $f readable] [chan event $f2 readable] \
+ [chan event $f3 readable] [chan event $f4 readable]
+} -cleanup {
chan close $f
chan close $f2
chan close $f3
chan close $f4
- set x
-} {{script 1} {script 2} {} {}}
-test chan-io-47.4 {file events on shared files and multiple interpreters} {testfevent fileevent} {
+} -result {{script 1} {script 2} {} {}}
+test chan-io-47.4 {file events on shared files and multiple interpreters} -setup {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
+} -constraints {testfevent fileevent} -body {
testfevent create
testfevent share $f
testfevent cmd "chan event $f readable {script 1}"
chan event $f readable {script 2}
chan event $f2 readable {script 3}
- set x [list [chan event $f2 readable] \
- [testfevent cmd "chan event $f readable"] \
- [chan event $f readable]]
+ list [chan event $f2 readable] [testfevent cmd "chan event $f readable"] \
+ [chan event $f readable]
+} -cleanup {
testfevent delete
chan close $f
chan close $f2
- set x
-} {{script 3} {script 1} {script 2}}
-test chan-io-47.5 {file events on shared files, deleting file events} {testfevent fileevent} {
+} -result {{script 3} {script 1} {script 2}}
+test chan-io-47.5 {file events on shared files, deleting file events} -setup {
set f [open $path(foo) r]
+} -body {
testfevent create
testfevent share $f
testfevent cmd "chan event $f readable {script 1}"
chan event $f readable {script 2}
testfevent cmd "chan event $f readable {}"
- set x [list [testfevent cmd "chan event $f readable"] \
- [chan event $f readable]]
+ list [testfevent cmd "chan event $f readable"] [chan event $f readable]
+} -constraints {testfevent fileevent} -cleanup {
testfevent delete
chan close $f
- set x
-} {{} {script 2}}
-test chan-io-47.6 {file events on shared files, deleting file events} {testfevent fileevent} {
+} -result {{} {script 2}}
+test chan-io-47.6 {file events on shared files, deleting file events} -setup {
set f [open $path(foo) r]
+} -body {
testfevent create
testfevent share $f
testfevent cmd "chan event $f readable {script 1}"
chan event $f readable {script 2}
chan event $f readable {}
- set x [list [testfevent cmd "chan event $f readable"] \
- [chan event $f readable]]
+ list [testfevent cmd "chan event $f readable"] [chan event $f readable]
+} -constraints {testfevent fileevent} -cleanup {
testfevent delete
chan close $f
- set x
-} {{script 1} {}}
+} -result {{script 1} {}}
set path(bar) [makeFile {} bar]
@@ -5710,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
@@ -5721,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]
@@ -5736,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
@@ -5748,14 +5890,17 @@ 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]
list $x $l
} {done {called called called called called called called}}
set path(my_script) [makeFile {} my_script]
-test chan-io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe fileevent} {
+test chan-io-48.3 {testing readability conditions} -setup {
+ set l ""
+} -constraints {stdio unix nonBlockFiles openpipe fileevent} -body {
set f [open $path(bar) w]
chan puts $f abcdefg
chan puts $f abcdefg
@@ -5774,13 +5919,8 @@ test chan-io-48.3 {testing readability conditions} {stdio unix nonBlockFiles ope
}
}
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 {
@@ -5789,28 +5929,31 @@ test chan-io-48.3 {testing readability conditions} {stdio unix nonBlockFiles ope
chan gets $f
lappend l [chan blocked $f]
}
- }
- set l ""
+ }]
+ 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]]"
chan puts $f {copy_slowly $f}
chan puts $f {exit}
vwait [namespace which -variable x]
- chan close $f
list $x $l
-} {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
-test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fileevent} {
+} -cleanup {
+ chan close $f
+} -result {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
+test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} -setup {
file delete $path(test1)
+ set c 0
+ set l ""
+} -constraints {fileevent} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
- variable c [format "abc\ndef\n%c" 26]
- chan puts -nonewline $f $c
+ 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
@@ -5818,27 +5961,23 @@ test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode
lappend l [chan gets $f]
incr c
}
- }
- set c 0
- set l ""
- 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
-} {3 {abc def {}}}
-test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {fileevent} {
+} -result {3 {abc def {}}}
+test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} -setup {
file delete $path(test1)
+ set c 0
+ set l ""
+} -constraints {fileevent} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
- set c [format "abc\ndef\n%cfoo\nbar\n" 26]
- chan puts -nonewline $f $c
+ 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
@@ -5846,27 +5985,23 @@ test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode}
lappend l [chan gets $f]
incr c
}
- }
- set c 0
- set l ""
- 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
-} {3 {abc def {}}}
-test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fileevent} {
+} -result {3 {abc def {}}}
+test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode} -setup {
file delete $path(test1)
+ set c 0
+ set l ""
+} -constraints {fileevent} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
- set c [format "abc\ndef\n%c" 26]
- chan puts -nonewline $f $c
+ 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
@@ -5874,27 +6009,23 @@ test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode
lappend l [chan gets $f]
incr c
}
- }
- set c 0
- set l ""
- 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
-} {3 {abc def {}}}
-test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {fileevent} {
+} -result {3 {abc def {}}}
+test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} -setup {
file delete $path(test1)
+ set c 0
+ set l ""
+} -constraints {fileevent} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
- set c [format "abc\ndef\n%cfoo\nbar\n" 26]
- chan puts -nonewline $f $c
+ 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
@@ -5902,27 +6033,23 @@ test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode}
lappend l [chan gets $f]
incr c
}
- }
- set c 0
- set l ""
- 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
-} {3 {abc def {}}}
-test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} {fileevent} {
+} -result {3 {abc def {}}}
+test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} -setup {
file delete $path(test1)
+ set c 0
+ set l ""
+} -constraints {fileevent} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
- set c [format "abc\ndef\n%c" 26]
- chan puts -nonewline $f $c
+ 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
@@ -5930,27 +6057,23 @@ test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mo
lappend l [chan gets $f]
incr c
}
- }
- set c 0
- set l ""
- 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
-} {3 {abc def {}}}
-test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fileevent} {
+} -result {3 {abc def {}}}
+test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} -setup {
file delete $path(test1)
+ set c 0
+ set l ""
+} -constraints {fileevent} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
- set c [format "abc\ndef\n%cfoo\nbar\n" 26]
- chan puts -nonewline $f $c
+ 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
@@ -5958,27 +6081,23 @@ test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode
lappend l [chan gets $f]
incr c
}
- }
- set c 0
- set l ""
- 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
-} {3 {abc def {}}}
-test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {fileevent} {
+} -result {3 {abc def {}}}
+test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} -setup {
file delete $path(test1)
+ set c 0
+ set l ""
+} -constraints {fileevent} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
- set c [format "abc\ndef\n%cfoo\nbar\n" 26]
- chan puts -nonewline $f $c
+ 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
@@ -5986,27 +6105,23 @@ test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {
lappend l [chan gets $f]
incr c
}
- }
- set c 0
- set l ""
- 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
-} {3 {abc def {}}}
-test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fileevent} {
+} -result {3 {abc def {}}}
+test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode} -setup {
file delete $path(test1)
+ set c 0
+ set l ""
+} -constraints {fileevent} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
- set c [format "abc\ndef\n%c" 26]
- chan puts -nonewline $f $c
+ 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
@@ -6014,27 +6129,23 @@ test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode}
lappend l [chan gets $f]
incr c
}
- }
- set c 0
- set l ""
- 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
-} {3 {abc def {}}}
-test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {fileevent} {
+} -result {3 {abc def {}}}
+test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} -setup {
file delete $path(test1)
+ set c 0
+ set l ""
+} -constraints {fileevent} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
- set c [format "abc\ndef\n%cfoo\nbar\n" 26]
- chan puts -nonewline $f $c
+ 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
@@ -6042,27 +6153,23 @@ test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {
lappend l [chan gets $f]
incr c
}
- }
- set c 0
- set l ""
- 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
-} {3 {abc def {}}}
-test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fileevent} {
+} -result {3 {abc def {}}}
+test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode} -setup {
file delete $path(test1)
+ set c 0
+ set l ""
+} -constraints {fileevent} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
- set c [format "abc\ndef\n%c" 26]
- chan puts -nonewline $f $c
+ 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
@@ -6070,27 +6177,23 @@ test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode}
lappend l [chan gets $f]
incr c
}
- }
- set c 0
- set l ""
- 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
-} {3 {abc def {}}}
-test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {fileevent} {
+} -result {3 {abc def {}}}
+test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} -setup {
file delete $path(test1)
+ set c 0
+ set l ""
+} -constraints {fileevent} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
- set c [format "abc\ndef\n%cfoo\nbar\n" 26]
- chan puts -nonewline $f $c
+ 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
@@ -6098,27 +6201,23 @@ test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mod
lappend l [chan gets $f]
incr c
}
- }
- set c 0
- set l ""
- 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
-} {3 {abc def {}}}
-test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {fileevent} {
+} -result {3 {abc def {}}}
+test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} -setup {
file delete $path(test1)
+ set c 0
+ set l ""
+} -constraints {fileevent} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
- set c [format "abc\ndef\n%c" 26]
- chan puts -nonewline $f $c
+ 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
@@ -6126,25 +6225,21 @@ test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {
lappend l [chan gets $f]
incr c
}
- }
- set c 0
- set l ""
- 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
-} {3 {abc def {}}}
+} -result {3 {abc def {}}}
-test chan-io-49.1 {testing crlf reading, leftover cr disgorgment} {
+test chan-io-49.1 {testing crlf reading, leftover cr disgorgment} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "a\rb\rc\r\n"
chan close $f
set f [open $path(test1) r]
- set l ""
lappend l [file size $path(test1)]
chan configure $f -translation crlf
lappend l [chan read $f 1]
@@ -6162,18 +6257,19 @@ test chan-io-49.1 {testing crlf reading, leftover cr disgorgment} {
lappend l [chan eof $f]
lappend l [chan read $f 1]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 {
+} -result "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 {
} 7 0 {} 1"
-test chan-io-49.2 {testing crlf reading, leftover cr disgorgment} {
+test chan-io-49.2 {testing crlf reading, leftover cr disgorgment} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "a\rb\rc\r\n"
chan close $f
set f [open $path(test1) r]
- set l ""
lappend l [file size $path(test1)]
chan configure $f -translation crlf
lappend l [chan read $f 2]
@@ -6186,17 +6282,18 @@ test chan-io-49.2 {testing crlf reading, leftover cr disgorgment} {
lappend l [chan read $f 2]
lappend l [chan tell $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1"
-test chan-io-49.3 {testing crlf reading, leftover cr disgorgment} {
+} -result "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1"
+test chan-io-49.3 {testing crlf reading, leftover cr disgorgment} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "a\rb\rc\r\n"
chan close $f
set f [open $path(test1) r]
- set l ""
lappend l [file size $path(test1)]
chan configure $f -translation crlf
lappend l [chan read $f 3]
@@ -6207,17 +6304,18 @@ test chan-io-49.3 {testing crlf reading, leftover cr disgorgment} {
lappend l [chan read $f 3]
lappend l [chan tell $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1"
-test chan-io-49.4 {testing crlf reading, leftover cr disgorgment} {
+} -result "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1"
+test chan-io-49.4 {testing crlf reading, leftover cr disgorgment} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "a\rb\rc\r\n"
chan close $f
set f [open $path(test1) r]
- set l ""
lappend l [file size $path(test1)]
chan configure $f -translation crlf
lappend l [chan read $f 3]
@@ -6228,17 +6326,18 @@ test chan-io-49.4 {testing crlf reading, leftover cr disgorgment} {
lappend l [chan gets $f]
lappend l [chan tell $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1"
-test chan-io-49.5 {testing crlf reading, leftover cr disgorgment} {
+} -result "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1"
+test chan-io-49.5 {testing crlf reading, leftover cr disgorgment} -setup {
file delete $path(test1)
+ set l ""
+} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "a\rb\rc\r\n"
chan close $f
set f [open $path(test1) r]
- set l ""
lappend l [file size $path(test1)]
chan configure $f -translation crlf
lappend l [set x [chan gets $f]]
@@ -6246,30 +6345,31 @@ test chan-io-49.5 {testing crlf reading, leftover cr disgorgment} {
lappend l [chan gets $f]
lappend l [chan tell $f]
lappend l [chan eof $f]
+} -cleanup {
chan close $f
- set l
-} [list 7 a\rb\rc 7 {} 7 1]
+} -result [list 7 a\rb\rc 7 {} 7 1]
-test chan-io-50.1 {testing handler deletion} {testchannelevent} {
+test chan-io-50.1 {testing handler deletion} -setup {
file delete $path(test1)
+} -constraints {testchannelevent} -body {
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 {
chan close $f
- set z
-} called
-test chan-io-50.2 {testing handler deletion with multiple handlers} {testchannelevent} {
+} -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]]
testchannelevent $f add readable [namespace code [list delhandler $f 0]]
@@ -6278,20 +6378,20 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} {testchannel
lappend z "called delhandler $f $i"
testchannelevent $f delete 0
}
- set z ""
update
- chan close $f
- string compare [string tolower $z] \
+ string equal $z \
[list [list called delhandler $f 0] [list called delhandler $f 1]]
-} 0
-test chan-io-50.3 {testing handler deletion with multiple handlers} {testchannelevent} {
- file delete $path(test1)
- set f [open $path(test1) w]
+} -cleanup {
chan close $f
+} -result 1
+test chan-io-50.3 {testing handler deletion with multiple handlers} -setup {
+ file delete $path(test1)
+ 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"
@@ -6303,23 +6403,21 @@ test chan-io-50.3 {testing handler deletion with multiple handlers} {testchannel
testchannelevent $f delete 0
lappend z "delhandler $f $i deleted myself"
}
- set z ""
update
- chan close $f
- string compare [string tolower $z] \
+ string equal $z \
[list [list delhandler $f 0 called] \
[list delhandler $f 0 deleted myself]]
-} 0
-test chan-io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} {
+} -cleanup {
+ chan close $f
+} -result 1
+test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup {
file delete $path(test1)
set f [open $path(test1) w]
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" == "recursive"} {
+ testchannelevent $f add readable [namespace code {
+ if {$u eq "recursive"} {
testchannelevent $f delete 0
lappend z "delrecursive deleting recursive"
} else {
@@ -6327,18 +6425,19 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} {testchanneleven
set u recursive
update
}
- }
+ }]
variable u toplevel
variable z ""
update
+ return $z
+} -cleanup {
chan close $f
- string compare [string tolower $z] \
- {{delrecursive calling recursive} {delrecursive deleting recursive}}
-} 0
-test chan-io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} {
+} -result {{delrecursive calling recursive} {delrecursive deleting recursive}}
+test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup {
file delete $path(test1)
set f [open $path(test1) w]
chan close $f
+} -constraints {testchannelevent} -body {
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list notcalled $f]]
testchannelevent $f add readable [namespace code [list del $f]]
@@ -6349,7 +6448,7 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} {testchanneleven
proc del {f} {
variable u
variable z
- if {"$u" == "recursive"} {
+ if {$u eq "recursive"} {
testchannelevent $f delete 1
testchannelevent $f delete 0
lappend z "del deleted notcalled"
@@ -6364,22 +6463,23 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} {testchanneleven
set z ""
set u toplevel
update
+ return $z
+} -cleanup {
chan close $f
- string compare [string tolower $z] \
- [list {del calling recursive} {del deleted notcalled} \
- {del deleted myself} {del after update}]
-} 0
-test chan-io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} {
+} -result [list {del calling recursive} {del deleted notcalled} \
+ {del deleted myself} {del after update}]
+test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup {
file delete $path(test1)
set f [open $path(test1) w]
chan close $f
+} -constraints {testchannelevent} -body {
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list second $f]]
testchannelevent $f add readable [namespace code [list first $f]]
proc first {f} {
variable u
variable z
- if {"$u" == "toplevel"} {
+ if {$u eq "toplevel"} {
lappend z "first called"
set u first
update
@@ -6391,11 +6491,11 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} {testchanneleven
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 {
@@ -6406,74 +6506,74 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} {testchanneleven
set z ""
set u toplevel
update
+ return $z
+} -cleanup {
chan close $f
- string compare [string tolower $z] \
- [list {first called} {first called not toplevel} \
- {second called, first time} {second called, second time} \
- {first after update}]
-} 0
+} -result [list {first called} {first called not toplevel} \
+ {second called, first time} {second called, second time} \
+ {first after update}]
-test chan-io-51.1 {Test old socket deletion on Macintosh} {socket} {
+test chan-io-51.1 {Test old socket deletion on Macintosh} -setup {
set x 0
set result ""
+ variable wait ""
+} -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]
- variable 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]
chan close $cs
- set wait ""
set cs [socket 127.0.0.1 $port]
vwait [namespace which -variable wait]
lappend result [chan gets $cs]
+} -cleanup {
chan close $cs
chan close $ss
- set result
-} {sock1 sock2 sock3 sock4}
+} -result {sock1 sock2 sock3 sock4}
-test chan-io-52.1 {TclCopyChannel} {fcopy} {
+test chan-io-52.1 {TclCopyChannel} -constraints {fcopy} -setup {
file delete $path(test1)
+} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
- chan copy $f1 $f2 -command { # }
- catch { chan copy $f1 $f2 } msg
+ chan copy $f1 $f2 -command " # "
+ chan copy $f1 $f2
+} -returnCodes error -cleanup {
chan close $f1
chan close $f2
- string compare $msg "channel \"$f1\" is busy"
-} {0}
-test chan-io-52.2 {TclCopyChannel} {fcopy} {
+} -match glob -result {channel "*" is busy}
+test chan-io-52.2 {TclCopyChannel} -constraints {fcopy} -setup {
file delete $path(test1)
+} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
set f3 [open $thisScript]
- chan copy $f1 $f2 -command { # }
- catch { chan copy $f3 $f2 } msg
+ chan copy $f1 $f2 -command " # "
+ chan copy $f3 $f2
+} -returnCodes error -cleanup {
chan close $f1
chan close $f2
chan close $f3
- string compare $msg "channel \"$f2\" is busy"
-} {0}
-test chan-io-52.3 {TclCopyChannel} {fcopy} {
+} -match glob -result {channel "*" is busy}
+test chan-io-52.3 {TclCopyChannel} -constraints {fcopy} -setup {
file delete $path(test1)
+} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation lf -blocking 0
@@ -6484,13 +6584,14 @@ test chan-io-52.3 {TclCopyChannel} {fcopy} {
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
}
- set result
-} {0 0 ok}
-test chan-io-52.4 {TclCopyChannel} {fcopy} {
+ return $result
+} -result {0 0 ok}
+test chan-io-52.4 {TclCopyChannel} -constraints {fcopy} -setup {
file delete $path(test1)
+} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation lf -blocking 0
@@ -6500,9 +6601,10 @@ test chan-io-52.4 {TclCopyChannel} {fcopy} {
chan close $f1
chan close $f2
lappend result [file size $path(test1)]
-} {0 0 40}
-test chan-io-52.5 {TclCopyChannel, all} {fcopy} {
+} -result {0 0 40}
+test chan-io-52.5 {TclCopyChannel, all} -constraints {fcopy} -setup {
file delete $path(test1)
+} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation lf -blocking 0
@@ -6511,15 +6613,14 @@ test chan-io-52.5 {TclCopyChannel, all} {fcopy} {
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
chan close $f1
chan close $f2
- set s1 [file size $thisScript]
- set s2 [file size $path(test1)]
- if {"$s1" == "$s2"} {
+ if {[file size $thisScript] == [file size $path(test1)]} {
lappend result ok
}
- set result
-} {0 0 ok}
-test chan-io-52.5a {TclCopyChannel, all, other negative value} {fcopy} {
+ return $result
+} -result {0 0 ok}
+test chan-io-52.5a {TclCopyChannel, all, other negative value} -setup {
file delete $path(test1)
+} -constraints {fcopy} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation lf -blocking 0
@@ -6528,15 +6629,14 @@ test chan-io-52.5a {TclCopyChannel, all, other negative value} {fcopy} {
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
chan close $f1
chan close $f2
- set s1 [file size $thisScript]
- set s2 [file size $path(test1)]
- if {"$s1" == "$s2"} {
+ if {[file size $thisScript] == [file size $path(test1)]} {
lappend result ok
}
- set result
-} {0 0 ok}
-test chan-io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} {
+ return $result
+} -result {0 0 ok}
+test chan-io-52.5b {TclCopyChannel, all, wrap to negative value} -setup {
file delete $path(test1)
+} -constraints {fcopy} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation lf -blocking 0
@@ -6545,15 +6645,14 @@ test chan-io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} {
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
chan close $f1
chan close $f2
- set s1 [file size $thisScript]
- set s2 [file size $path(test1)]
- if {"$s1" == "$s2"} {
+ if {[file size $thisScript] == [file size $path(test1)]} {
lappend result ok
}
- set result
-} {0 0 ok}
-test chan-io-52.6 {TclCopyChannel} {fcopy} {
+ return $result
+} -result {0 0 ok}
+test chan-io-52.6 {TclCopyChannel} -setup {
file delete $path(test1)
+} -constraints {fcopy} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation lf -blocking 0
@@ -6564,31 +6663,32 @@ test chan-io-52.6 {TclCopyChannel} {fcopy} {
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
}
- set result
-} {0 0 ok}
-test chan-io-52.7 {TclCopyChannel} {fcopy} {
+ return $result
+} -result {0 0 ok}
+test chan-io-52.7 {TclCopyChannel} -constraints {fcopy} -setup {
file delete $path(test1)
+} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation lf -blocking 0
chan configure $f2 -translation lf -blocking 0
chan copy $f1 $f2
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
- set s1 [file size $thisScript]
- set s2 [file size $path(test1)]
- chan close $f1
- chan close $f2
- if {"$s1" == "$s2"} {
+ if {[file size $thisScript] == [file size $path(test1)]} {
lappend result ok
}
- set result
-} {0 0 ok}
-test chan-io-52.8 {TclCopyChannel} {stdio openpipe fcopy} {
+ return $result
+} -cleanup {
+ chan close $f1
+ chan close $f2
+} -result {0 0 ok}
+test chan-io-52.8 {TclCopyChannel} -setup {
file delete $path(test1)
file delete $path(pipe)
+} -constraints {stdio openpipe fcopy} -body {
set f1 [open $path(pipe) w]
chan configure $f1 -translation lf
chan puts $f1 "
@@ -6600,7 +6700,7 @@ test chan-io-52.8 {TclCopyChannel} {stdio openpipe fcopy} {
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
@@ -6611,7 +6711,7 @@ test chan-io-52.8 {TclCopyChannel} {stdio openpipe fcopy} {
catch {chan close $f1}
chan close $f2
list $s0 [file size $path(test1)]
-} {40 40}
+} -result {40 40}
# Empty files, to register them with the test facility
set path(kyrillic.txt) [makeFile {} kyrillic.txt]
set path(utf8-fcopy.txt) [makeFile {} utf8-fcopy.txt]
@@ -6668,8 +6768,9 @@ test chan-io-52.11 {TclCopyChannel & encodings} {fcopy} {
file size $path(kyrillic.txt)
} 3
-test chan-io-53.1 {CopyData} {fcopy} {
+test chan-io-53.1 {CopyData} -setup {
file delete $path(test1)
+} -constraints {fcopy} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation lf -blocking 0
@@ -6679,9 +6780,10 @@ test chan-io-53.1 {CopyData} {fcopy} {
chan close $f1
chan close $f2
lappend result [file size $path(test1)]
-} {0 0 0}
-test chan-io-53.2 {CopyData} {fcopy} {
+} -result {0 0 0}
+test chan-io-53.2 {CopyData} -setup {
file delete $path(test1)
+} -constraints {fcopy} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation lf -blocking 0
@@ -6694,18 +6796,19 @@ test chan-io-53.2 {CopyData} {fcopy} {
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
}
- set result
-} {0 0 ok}
-test chan-io-53.3 {CopyData: background read underflow} {stdio unix openpipe fcopy} {
+ return $result
+} -result {0 0 ok}
+test chan-io-53.3 {CopyData: background read underflow} -setup {
file delete $path(test1)
file delete $path(pipe)
+} -constraints {stdio unix openpipe fcopy} -body {
set f1 [open $path(pipe) w]
chan puts -nonewline $f1 {
chan puts ready
- chan flush stdout ;# Don't assume line buffered!
+ chan flush stdout ;# Don't assume line buffered!
chan copy stdin stdout -command { set x }
vwait x
set f [}
@@ -6716,7 +6819,7 @@ test chan-io-53.3 {CopyData: background read underflow} {stdio unix openpipe fco
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
@@ -6728,10 +6831,10 @@ test chan-io-53.3 {CopyData: background read underflow} {stdio unix openpipe fco
after 500
set f [open $path(test1)]
lappend result [chan read $f]
+} -cleanup {
chan close $f
- set result
-} "ready line1 line2 {done\n}"
-test chan-io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileevent fcopy} {
+} -result "ready line1 line2 {done\n}"
+test chan-io-53.4 {CopyData: background write overflow} -setup {
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
variable x
for {set x 0} {$x < 12} {incr x} {
@@ -6739,6 +6842,7 @@ test chan-io-53.4 {CopyData: background write overflow} {stdio unix openpipe fil
}
file delete $path(test1)
file delete $path(pipe)
+} -constraints {stdio unix openpipe fileevent fcopy} -body {
set f1 [open $path(pipe) w]
chan puts $f1 {
chan puts ready
@@ -6750,7 +6854,7 @@ test chan-io-53.4 {CopyData: background write overflow} {stdio unix openpipe fil
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
@@ -6764,10 +6868,11 @@ test chan-io-53.4 {CopyData: background write overflow} {stdio unix openpipe fil
}
}]
vwait [namespace which -variable x]
- chan close $f1
+ return $x
+} -cleanup {
set big {}
- set x
-} done
+ chan close $f1
+} -result done
set result {}
proc FcopyTestAccept {sock args} {
after 1000 "chan close $sock"
@@ -6796,25 +6901,27 @@ test chan-io-53.5 {CopyData: error during chan copy} {socket fcopy} {
chan close $out
set fcopyTestDone ;# 1 for error condition
} 1
-test chan-io-53.6 {CopyData: error during chan copy} {stdio openpipe fcopy} {
+test chan-io-53.6 {CopyData: error during chan copy} -setup {
variable fcopyTestDone
file delete $path(pipe)
file delete $path(test1)
catch {unset fcopyTestDone}
+} -constraints {stdio openpipe fcopy} -body {
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
if ![info exists fcopyTestDone] {
vwait [namespace which -variable fcopyTestDone]
}
+ return $fcopyTestDone ;# 0 for plain end of file
+} -cleanup {
catch {chan close $in}
chan close $out
- set fcopyTestDone ;# 0 for plain end of file
-} {0}
+} -result 0
proc doFcopy {in out {bytes 0} {error {}}} {
variable fcopyTestDone
variable fcopyTestCount
@@ -6829,10 +6936,11 @@ proc doFcopy {in out {bytes 0} {error {}}} {
-command [namespace code [list doFcopy $in $out]]]
}
}
-test chan-io-53.7 {CopyData: Flooding chan copy from pipe} {stdio openpipe fcopy} {
+test chan-io-53.7 {CopyData: Flooding chan copy from pipe} -setup {
variable fcopyTestDone
file delete $path(pipe)
catch {unset fcopyTestDone}
+} -constraints {stdio openpipe fcopy} -body {
set fcopyTestCount 0
set f1 [open $path(pipe) w]
chan puts $f1 {
@@ -6851,21 +6959,22 @@ test chan-io-53.7 {CopyData: Flooding chan copy from pipe} {stdio openpipe fcopy
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
- if ![info exists fcopyTestDone] {
+ if {![info exists fcopyTestDone]} {
vwait [namespace which -variable fcopyTestDone]
}
- catch {chan close $in}
- chan close $out
# -1=error 0=script error N=number of bytes
expr ($fcopyTestDone == 0) ? $fcopyTestCount : -1
-} {3450}
+} -cleanup {
+ catch {chan close $in}
+ chan close $out
+} -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
}
@@ -6885,12 +6994,12 @@ 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
- # Now let the async part happen. Should capture the error in cmd
- # via bgerror. If not break the event loop via timer.
+ # Now let the async part happen. Should capture the error in cmd via
+ # bgerror. If not break the event loop via timer.
set token [after 1000 {
lappend ::RES {bgerror/FAIL timeout}
set ::forever has-been-reached
@@ -6898,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
@@ -6927,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
@@ -6939,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}}
@@ -6992,8 +7099,10 @@ test chan-io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup {
} -cleanup {
chan close $pipe
rename ::done {}
- after 1000; # Allow Windows time to figure out that the
+ if {[testConstraint win]} {
+ after 1000; # Allow Windows time to figure out that the
# process is gone
+ }
catch {close $out}
catch {removeFile out}
catch {removeFile err}
@@ -7021,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]
@@ -7041,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
@@ -7050,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 {}
@@ -7064,8 +7173,9 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup {
catch {chan close $a}
catch {chan close $b}
chan close $pipe
- rename ::done {}
- after 1000 ;# Give Windows time to kill the process
+ if {[testConstraint win]} {
+ after 1000 ;# Give Windows time to kill the process
+ }
removeFile err
catch {unset ::forever}
} -result {AB BA}
@@ -7095,7 +7205,9 @@ test chan-io-54.1 {Recursive channel events} {socket fileevent} {
# completes.
set done 0
for {set i 0} {$i < 10} {incr i} {
- if {![catch {set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]]}]} {
+ if {![catch {
+ set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]]
+ }]} then {
set done 1
break
}
@@ -7121,9 +7233,11 @@ test chan-io-54.1 {Recursive channel events} {socket fileevent} {
chan close $cs
list $result $x
} {{{line 1} 1 2} 2}
-test chan-io-54.2 {Testing for busy-wait in 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} {
variable counter 0
@@ -7135,17 +7249,20 @@ test chan-io-54.2 {Testing for busy-wait in recursive channel events} {socket fi
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 {}
}
@@ -7157,22 +7274,15 @@ test chan-io-54.2 {Testing for busy-wait in recursive channel events} {socket fi
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
after cancel $after
+ return $counter
+} -cleanup {
if {$accept ne {}} {chan close $accept}
- set counter
-} 1
+} -result 1
set path(fooBar) [makeFile {} fooBar]
@@ -7196,7 +7306,7 @@ test chan-io-55.1 {ChannelEventScriptInvoker: deletion} -constraints {
chan event $f writable [namespace code [list eventScript $f]]
variable x not_done
vwait [namespace which -variable x]
- set x
+ return $x
} -cleanup {
interp bgerror {} $handler
} -result {got_error}
@@ -7222,14 +7332,15 @@ test chan-io-56.1 {ChannelTimerProc} {testchannelevent} {
lappend result $y
} {2 done}
-test chan-io-57.1 {buffered data and file events, gets} {fileevent} {
+test chan-io-57.1 {buffered data and file events, gets} -setup {
+ variable s2
+} -constraints {fileevent} -body {
proc accept {sock args} {
variable s2
set s2 $sock
}
set server [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
set s [socket 127.0.0.1 [lindex [chan configure $server -sockname] 2]]
- variable s2
vwait [namespace which -variable s2]
update
chan event $s2 readable [namespace code {lappend result readable}]
@@ -7240,19 +7351,21 @@ test chan-io-57.1 {buffered data and file events, gets} {fileevent} {
vwait [namespace which -variable result]
lappend result [chan gets $s2]
vwait [namespace which -variable result]
+ return $result
+} -cleanup {
chan close $s
chan close $s2
chan close $server
- set result
-} {12 readable 34567890 timer}
-test chan-io-57.2 {buffered data and file events, read} {fileevent} {
+} -result {12 readable 34567890 timer}
+test chan-io-57.2 {buffered data and file events, read} -setup {
+ variable s2
+} -constraints {fileevent} -body {
proc accept {sock args} {
variable s2
set s2 $sock
}
set server [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
set s [socket 127.0.0.1 [lindex [chan configure $server -sockname] 2]]
- variable s2
vwait [namespace which -variable s2]
update
chan event $s2 readable [namespace code {lappend result readable}]
@@ -7263,11 +7376,12 @@ test chan-io-57.2 {buffered data and file events, read} {fileevent} {
vwait [namespace which -variable result]
lappend result [chan read $s2 9]
vwait [namespace which -variable result]
+ return $result
+} -cleanup {
chan close $s
chan close $s2
chan close $server
- set result
-} {1 readable 234567890 timer}
+} -result {1 readable 234567890 timer}
test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc openpipe fileevent} {
set out [open $path(script) w]
@@ -7288,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 ""
@@ -7327,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 ""
@@ -7358,9 +7472,8 @@ test chan-io-61.1 {Reset eof state after changing the eof char} -setup {
#chan seek $f 0 start
#chan seek $f 0 current
#lappend res [chan read $f; chan tell $f]
- chan close $f
- set res
} -cleanup {
+ chan close $f
removeFile eofchar
} -result {77 = 23431}
@@ -7369,19 +7482,20 @@ test chan-io-61.1 {Reset eof state after changing the eof char} -setup {
# can also be used to emulate transfer of channels between threads, and is
# used for that here.
-test chan-io-70.0 {Cutting & Splicing channels} {testchannel} {
+test chan-io-70.0 {Cutting & Splicing channels} -setup {
set f [makeFile {... dummy ...} cutsplice]
+ set res {}
+} -constraints {testchannel} -body {
set c [open $f r]
- set res {}
lappend res [catch {chan seek $c 0 start}]
testchannel cut $c
lappend res [catch {chan seek $c 0 start}]
testchannel splice $c
lappend res [catch {chan seek $c 0 start}]
+} -cleanup {
chan close $c
removeFile cutsplice
- set res
-} {0 1 0}
+} -result {0 1 0}
# Duplicate of code in "thread.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.
@@ -7395,10 +7509,11 @@ if {[testConstraint testthread]} {
# ignore
}
}
-test chan-io-70.1 {Transfer channel} {testchannel testthread} {
+test chan-io-70.1 {Transfer channel} -setup {
set f [makeFile {... dummy ...} cutsplice]
+ set res {}
+} -constraints {testchannel testthread} -body {
set c [open $f r]
- set res {}
lappend res [catch {chan seek $c 0 start}]
testchannel cut $c
lappend res [catch {chan seek $c 0 start}]
@@ -7410,10 +7525,10 @@ test chan-io-70.1 {Transfer channel} {testchannel testthread} {
chan close $c
set res
}]
+} -cleanup {
tcltest::threadReap
removeFile cutsplice
- set res
-} {0 1 0}
+} -result {0 1 0}
# ### ### ### ######### ######### #########
@@ -7578,28 +7693,30 @@ foreach {n msg expected} {
f2 {-code ok -code 0 -level X -f ba} {-code 1 -level 0 -f ba}
f3 {-code boss -code 0 -level X -f ba} {-code 1 -level 0 -f ba}
} {
- test chan-io-71.$n {Tcl_SetChannelError} {testchannel} {
+ test chan-io-71.$n {Tcl_SetChannelError} -setup {
set f [makeFile {... dummy ...} cutsplice]
+ } -constraints {testchannel} -body {
set c [open $f r]
- set res [testchannel setchannelerror $c [lrange $msg 0 end]]
+ testchannel setchannelerror $c [lrange $msg 0 end]
+ } -cleanup {
chan close $c
removeFile cutsplice
- set res
- } [lrange $expected 0 end]
- test chan-io-72.$n {Tcl_SetChannelErrorInterp} {testchannel} {
+ } -result [lrange $expected 0 end]
+ test chan-io-72.$n {Tcl_SetChannelErrorInterp} -setup {
set f [makeFile {... dummy ...} cutsplice]
+ } -constraints {testchannel} -body {
set c [open $f r]
- set res [testchannel setchannelerrorinterp $c [lrange $msg 0 end]]
+ testchannel setchannelerrorinterp $c [lrange $msg 0 end]
+ } -cleanup {
chan close $c
removeFile cutsplice
- set res
- } [lrange $expected 0 end]
+ } -result [lrange $expected 0 end]
}
-test chan-io-73.1 {channel Tcl_Obj SetChannelFromAny} {} {
+test chan-io-73.1 {channel Tcl_Obj SetChannelFromAny} -body {
# Test for Bug 1847044 - don't spoil type unless we have a valid channel
- catch {chan close [lreplace [list a] 0 end]}
-} {1}
+ chan close [lreplace [list a] 0 end]
+} -returnCodes error -match glob -result *
# ### ### ### ######### ######### #########
diff --git a/tests/error.test b/tests/error.test
index a6e487d..2e75c27 100644
--- a/tests/error.test
+++ b/tests/error.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: error.test,v 1.33.2.1 2010/10/23 15:49:54 kennykb Exp $
+# RCS: @(#) $Id: error.test,v 1.33.2.2 2010/12/01 16:42:36 kennykb Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -912,6 +912,72 @@ test error-19.10 {compiled try with chained clauses} -setup {
} -cleanup {
unset RES
} -result {handler {ok good finally}}
+test error-19.11 {compiled try and errors on variable write} -setup {
+ set RES {}
+} -body {
+ apply {{} {
+ array set foo {bar boo}
+ set bar unset
+ catch {
+ try {
+ addmsg body
+ return a
+ } on return {bar foo} {
+ addmsg handler
+ return b
+ } finally {
+ addmsg finally,$bar
+ }
+ } msg
+ addmsg $msg
+ } ::tcl::test::error}
+} -cleanup {
+ unset RES
+} -result {body finally,a {can't set "foo": variable is array}}
+test error-19.12 {interpreted try and errors on variable write} -setup {
+ set RES {}
+} -body {
+ apply {try {
+ array set foo {bar boo}
+ set bar unset
+ catch {
+ $try {
+ addmsg body
+ return a
+ } on return {bar foo} {
+ addmsg handler
+ return b
+ } finally {
+ addmsg finally,$bar
+ }
+ } msg
+ addmsg $msg
+ } ::tcl::test::error} try
+} -cleanup {
+ unset RES
+} -result {body finally,a {can't set "foo": variable is array}}
+test error-19.13 {compiled try and errors on variable write} -setup {
+ set RES {}
+} -body {
+ apply {{} {
+ array set foo {bar boo}
+ set bar unset
+ catch {
+ try {
+ addmsg body
+ return a
+ } on return {bar foo} - on error {bar foo} {
+ addmsg handler
+ return b
+ } finally {
+ addmsg finally,$bar
+ }
+ } msg
+ addmsg $msg
+ } ::tcl::test::error}
+} -cleanup {
+ unset RES
+} -result {body finally,a {can't set "foo": variable is array}}
rename addmsg {}
# FIXME test what vars get set on fallthough ... what is the correct behavior?
diff --git a/tests/info.test b/tests/info.test
index fd126a7..810c57d 100644
--- a/tests/info.test
+++ b/tests/info.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: info.test,v 1.78 2010/08/03 20:15:53 andreas_kupries Exp $
+# RCS: @(#) $Id: info.test,v 1.78.2.1 2010/12/01 16:42:37 kennykb Exp $
if {{::tcltest} ni [namespace children]} {
package require tcltest 2
@@ -690,14 +690,12 @@ test info-21.5 {miscellaneous error conditions} -returnCodes error -body {
##
# ### ### ### ######### ######### #########
## info frame
-
## Helper
# For the more complex results we cut the file name down to remove path
# dependencies, and we use only part of the first line of the reported
# command. The latter is required because otherwise the whole test case may
# appear in some results, but the result is part of the testcase. An infinite
# string would be required to describe that. The cutting-down breaks this.
-
proc reduce {frame} {
set pos [lsearch -exact $frame cmd]
incr pos
@@ -714,7 +712,9 @@ proc reduce {frame} {
}
set frame
}
-
+proc subinterp {} { interp create sub ; interp debug sub -frame 1;
+ interp eval sub [list proc reduce [info args reduce] [info body reduce]]
+}
## Helper
# Generate a stacktrace from the current location to top. This code
# not only depends on the exact location of things, but also on the
@@ -1363,14 +1363,14 @@ test info-38.1 {location information for uplevel, dv, direct-var} -match glob -b
* {type eval line 3 cmd etrace proc ::tcltest::RunTest}
* {type source line 1361 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y}
-test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -body {
- join [lrange [uplevel \#0 {
- set y DL.
- etrace
- }] 0 2] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
-* {type source line 1369 file info.test cmd etrace proc ::tcltest::RunTest}
-* {type source line 1367 file info.test cmd uplevel\\ \\\\ proc ::tcltest::RunTest}} -cleanup {unset y}
+# 38.2 moved to bottom to not disturb other tests with the necessary changes to this one.
+
+
+
+
+
+
+
test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match glob -body {
set script {
@@ -1383,15 +1383,15 @@ test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match g
* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1380 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y}
-test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -body {
- join [lrange [control y {
- set y DPL
- etrace
- }] 0 3] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
-* {type source line 1389 file info.test cmd etrace proc ::control}
-* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
-* {type source line 1387 file info.test cmd control proc ::tcltest::RunTest}} -cleanup {unset y}
+# 38.4 moved to bottom to not disturb other tests with the necessary changes to this one.
+
+
+
+
+
+
+
+
test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body {
join [lrange [datav] 0 4] \n
@@ -1401,13 +1401,13 @@ test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glo
* {type source line 1353 file info.test cmd {control y $script} proc ::datav level 1}
* {type source line 1397 file info.test cmd datav proc ::tcltest::RunTest}}
-test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match glob -body {
- join [lrange [datal] 0 4] \n
-} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0}
-* {type source line 1344 file info.test cmd etrace proc ::control}
-* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
-* {type source line 1342 file info.test cmd control proc ::datal level 1}
-* {type source line 1405 file info.test cmd datal proc ::tcltest::RunTest}}
+# 38.6 moved to bottom to not disturb other tests with the necessary changes to this one.
+
+
+
+
+
+
testConstraint testevalex [llength [info commands testevalex]]
test info-38.7 {location information for arg substitution} -constraints testevalex -match glob -body {
@@ -1543,18 +1543,18 @@ test info-30.12 {bs+nl in computed word, nested eval} -body {
} -cleanup {unset res x} -result { type source line 1541 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
test info-30.13 {bs+nl in literal words, uplevel script, with nested words} -body {
- uplevel #0 {
+ subinterp ; set res [interp eval sub { uplevel #0 {
if {1} \
{
set ::res \
[reduce [info frame 0]];# line 1550
}
}
- return $res
-} -cleanup {unset res} -result {type source line 1550 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+ set res }] ; interp delete sub ; set res
+} -cleanup {unset res} -result {type source line 1550 file info.test cmd {info frame 0} level 0}
test info-30.14 {bs+nl, literal word, uplevel through proc} {
- proc abra {script} {
+ subinterp ; set res [interp eval sub { proc abra {script} {
uplevel 1 $script
}
set res [abra {
@@ -1562,7 +1562,7 @@ test info-30.14 {bs+nl, literal word, uplevel through proc} {
[reduce [info frame 0]]";# line 1562
}]
rename abra {}
- set res
+ set res }] ; interp delete sub ; set res
} { type source line 1562 file info.test cmd {info frame 0} proc ::abra}
test info-30.15 {bs+nl in literal words, nested proc body, compiled} {
@@ -1879,6 +1879,83 @@ test info-39.1 {location information not confused by literal sharing, bug 293308
type source line 1859 file info.test cmd print_one proc ::test_info_frame level 1}
# -------------------------------------------------------------------------
+# Tests moved to the end to not disturb other tests and their locations.
+
+test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match glob -setup {subinterp} -body {
+ interp eval sub {
+ proc etrace {} {
+ set res {}
+ set level [info frame]
+ while {$level} {
+ lappend res [list $level [reduce [info frame $level]]]
+ incr level -1
+ }
+ return $res
+ }
+ proc control {vv script} {
+ upvar 1 $vv var
+ return [uplevel 1 $script]
+ }
+ proc datal {} {
+ control y {
+ set y PPL
+ etrace
+ }
+ }
+ join [lrange [datal] 0 4] \n
+ }
+} -result {* {type source line 1890 file info.test cmd {info frame $level} proc ::etrace level 0}
+* {type source line 1902 file info.test cmd etrace proc ::control}
+* {type source line 1897 file info.test cmd {uplevel 1 $script} proc ::control}
+* {type source line 1900 file info.test cmd control proc ::datal level 1}
+* {type source line 1905 file info.test cmd datal level 2}} -cleanup {interp delete sub}
+
+test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -setup {subinterp} -body {
+ interp eval sub {
+ proc etrace {} {
+ set res {}
+ set level [info frame]
+ while {$level} {
+ lappend res [list $level [reduce [info frame $level]]]
+ incr level -1
+ }
+ return $res
+ }
+ proc control {vv script} {
+ upvar 1 $vv var
+ return [uplevel 1 $script]
+ }
+ join [lrange [control y {
+ set y DPL
+ etrace
+ }] 0 3] \n
+ }
+} -result {* {type source line 1919 file info.test cmd {info frame $level} proc ::etrace level 0}
+* {type source line 1930 file info.test cmd etrace proc ::control}
+* {type source line 1926 file info.test cmd {uplevel 1 $script} proc ::control}
+* {type source line 1928 file info.test cmd control level 1}} -cleanup {interp delete sub}
+
+test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -setup {subinterp} -body {
+ interp eval sub {
+ proc etrace {} {
+ set res {}
+ set level [info frame]
+ while {$level} {
+ lappend res [list $level [reduce [info frame $level]]]
+ incr level -1
+ }
+ return $res
+ }
+ join [lrange [uplevel \#0 {
+ set y DL.
+ etrace
+ }] 0 2] \n
+ }
+} -result {* {type source line 1944 file info.test cmd {info frame $level} proc ::etrace level 0}
+* {type source line 1951 file info.test cmd etrace level 1}
+* {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub}
+
+# -------------------------------------------------------------------------
unset -nocomplain res
# cleanup
diff --git a/tests/interp.test b/tests/interp.test
index 45254ad..6c35cfd 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: interp.test,v 1.68 2009/12/29 14:55:42 dkf Exp $
+# RCS: @(#) $Id: interp.test,v 1.68.4.1 2010/12/01 16:42:37 kennykb Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
@@ -31,7 +31,7 @@ test interp-1.1 {options for interp command} -returnCodes error -body {
} -result {wrong # args: should be "interp cmd ?arg ...?"}
test interp-1.2 {options for interp command} -returnCodes error -body {
interp frobox
-} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
+} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
test interp-1.3 {options for interp command} {
interp delete
} ""
@@ -49,13 +49,13 @@ test interp-1.6 {options for interp command} -returnCodes error -body {
} -result {wrong # args: should be "interp slaves ?path?"}
test interp-1.7 {options for interp command} -returnCodes error -body {
interp hello
-} -result {bad option "hello": must be alias, aliases, bgerror, cancel, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
+} -result {bad option "hello": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
test interp-1.8 {options for interp command} -returnCodes error -body {
interp -froboz
-} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
+} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
test interp-1.9 {options for interp command} -returnCodes error -body {
interp -froboz -safe
-} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
+} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
test interp-1.10 {options for interp command} -returnCodes error -body {
interp target
} -result {wrong # args: should be "interp target path alias"}
@@ -3596,6 +3596,50 @@ test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup {
unset result
interp delete a
} -result {26 26}
+
+test interp-38.1 {interp debug one-way switch} -setup {
+ catch {interp delete a}
+ interp create a
+ interp debug a -frame 1
+} -body {
+ # TIP #3xx interp debug frame is a one-way switch
+ interp debug a -frame 0
+} -cleanup {
+ interp delete a
+} -result {1}
+test interp-38.2 {interp debug env var} -setup {
+ catch {interp delete a}
+ set ::env(TCL_INTERP_DEBUG_FRAME) 1
+ interp create a
+} -body {
+ interp debug a
+} -cleanup {
+ unset ::env(TCL_INTERP_DEBUG_FRAME)
+ interp delete a
+} -result {-frame 1}
+test interp-38.3 {interp debug wrong args} -body {
+ interp debug
+} -returnCodes {
+ error
+} -result {wrong # args: should be "interp debug path ?-frame ?bool??"}
+test interp-38.4 {interp debug basic setup} -body {
+ interp debug {}
+} -result {-frame 0}
+test interp-38.5 {interp debug basic setup} -body {
+ interp debug {} -f
+} -result {0}
+test interp-38.6 {interp debug basic setup} -body {
+ interp debug -frames
+} -returnCodes error -result {could not find interpreter "-frames"}
+test interp-38.7 {interp debug basic setup} -body {
+ interp debug {} -frames
+} -returnCodes error -result {bad debug option "-frames": must be -frame}
+test interp-38.8 {interp debug basic setup} -body {
+ interp debug {} -frame 0 bogus
+} -returnCodes {
+ error
+} -result {wrong # args: should be "interp debug path ?-frame ?bool??"}
+
# cleanup
foreach i [interp slaves] {
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
index 8932874..049b0ce 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.9.2.1 2010/12/01 16:42:37 kennykb 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..d2e1997 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.16.10.1 2010/12/01 16:42:37 kennykb 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
diff --git a/tests/main.test b/tests/main.test
index 24d1fb5..d4b790a 100644
--- a/tests/main.test
+++ b/tests/main.test
@@ -1,6 +1,6 @@
# This file contains a collection of tests for generic/tclMain.c.
#
-# RCS: @(#) $Id: main.test,v 1.22 2007/12/13 15:26:06 dgp Exp $
+# RCS: @(#) $Id: main.test,v 1.22.8.1 2010/12/01 16:42:37 kennykb Exp $
if {[catch {package require tcltest 2.0.2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
@@ -68,8 +68,6 @@ namespace eval ::tcl::test::main {
} -result [list [interpreter] -script 0]\n
test Tcl_Main-1.3 {
- Tcl_Main: encoding of arguments: done by system encoding
- Note the shortcoming explained in Tcl Feature Request 491789
} -constraints {
stdio
} -setup {
@@ -84,10 +82,8 @@ namespace eval ::tcl::test::main {
[encoding convertto [encoding system] \u00c0]]] 0]\n
test Tcl_Main-1.4 {
- Tcl_Main: encoding of arguments: done by system encoding
- Note the shortcoming explained in Tcl Feature Request 491789
} -constraints {
- stdio tempNotWin
+ stdio
} -setup {
makeFile {puts [list $argv0 $argv $tcl_interactive]} script
catch {set f [open "|[list [interpreter] script \u20ac]" r]}
@@ -100,8 +96,6 @@ namespace eval ::tcl::test::main {
[encoding convertto [encoding system] \u20ac]]] 0]\n
test Tcl_Main-1.5 {
- Tcl_Main: encoding of script name: system encoding loss
- Note the shortcoming explained in Tcl Feature Request 491789
} -constraints {
stdio
} -setup {
@@ -116,10 +110,8 @@ namespace eval ::tcl::test::main {
[encoding convertto [encoding system] \u00c0]]] {} 0]\n
test Tcl_Main-1.6 {
- Tcl_Main: encoding of script name: system encoding loss
- Note the shortcoming explained in Tcl Feature Request 491789
} -constraints {
- stdio tempNotWin
+ stdio
} -setup {
makeFile {puts [list $argv0 $argv $tcl_interactive]} \u20ac
catch {set f [open "|[list [interpreter] \u20ac]" r]}
diff --git a/tests/oo.test b/tests/oo.test
index 50edb11..6e24553 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -7,7 +7,7 @@
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: oo.test,v 1.39 2010/03/24 13:21:11 dkf Exp $
+# RCS: @(#) $Id: oo.test,v 1.39.2.1 2010/12/01 16:42:37 kennykb Exp $
package require -exact TclOO 0.6.2 ;# Must match value in generic/tclOO.h
if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -96,6 +96,18 @@ test oo-0.7 {cleaning the core class pair; way #2} -setup {
} -cleanup {
interp delete t
} -result {0 {} 1 {invalid command name "class"}}
+test oo-0.8 {leak in variable management} -setup {
+ oo::class create foo
+} -constraints memory -body {
+ oo::define foo {
+ constructor {} {
+ variable v 0
+ }
+ }
+ leaktest {[foo new] destroy}
+} -cleanup {
+ foo destroy
+} -result 0
test oo-1.1 {basic test of OO functionality: no classes} {
set result {}
@@ -2044,6 +2056,18 @@ test oo-20.15 {OO: variable method use in non-methods [Bug 2903811]} -setup {
apply {{} {fooObj variable x; set x ok; return}}
return [set [fooObj varname x]]
} -result ok
+test oo-20.16 {variable method: leak per instance} -setup {
+ oo::class create foo
+} -constraints memory -body {
+ oo::define foo {
+ constructor {} {
+ set [my variable v] 0
+ }
+ }
+ leaktest {[foo new] destroy}
+} -cleanup {
+ foo destroy
+} -result 0
test oo-21.1 {OO: inheritance ordering} -setup {
oo::class create A
@@ -2531,6 +2555,19 @@ test oo-27.11 {variables declaration - no instance var leaks with class resolver
inst1 step
list [inst1 value] [inst2 value]
} -result {3 2}
+test oo-27.12 {variables declaration: leak per instance} -setup {
+ oo::class create foo
+} -constraints memory -body {
+ oo::define foo {
+ variable v
+ constructor {} {
+ set v 0
+ }
+ }
+ leaktest {[foo new] destroy}
+} -cleanup {
+ foo destroy
+} -result 0
# A feature that's not supported because the mechanism may change without
# warning, but is supposed to work...
@@ -2578,6 +2615,40 @@ test oo-30.2 {Bug 2903011: deleting an object in a constructor} -setup {
} -returnCodes error -cleanup {
cls destroy
} -result {object deleted in constructor}
+
+test oo-31.1 {Bug 3111059: when objects and coroutines entangle} -setup {
+ oo::class create cls
+} -constraints memory -body {
+ oo::define cls {
+ method justyield {} {
+ yield
+ }
+ constructor {} {
+ coroutine coro my justyield
+ }
+ }
+ list [leaktest {[cls new] destroy}] [info class instances cls]
+} -cleanup {
+ cls destroy
+} -result {0 {}}
+test oo-31.2 {Bug 3111059: when objects and coroutines entangle} -setup {
+ oo::class create cls
+} -constraints memory -body {
+ oo::define cls {
+ method justyield {} {
+ yield
+ }
+ constructor {} {
+ coroutine coro my justyield
+ }
+ destructor {
+ rename coro {}
+ }
+ }
+ list [leaktest {[cls new] destroy}] [info class instances cls]
+} -cleanup {
+ cls destroy
+} -result {0 {}}
cleanupTests
return
diff --git a/tests/remote.tcl b/tests/remote.tcl
index 880abc2..de827de 100644
--- a/tests/remote.tcl
+++ b/tests/remote.tcl
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: remote.tcl,v 1.3.56.1 2010/09/28 15:43:01 kennykb Exp $
+# RCS: @(#) $Id: remote.tcl,v 1.3.56.2 2010/12/01 16:42:37 kennykb Exp $
# Initialize message delimitor
@@ -156,5 +156,6 @@ if {[catch {set serverSocket \
[socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} {
puts "Server on $serverAddress:$serverPort cannot start: $msg"
} else {
+ puts ready
vwait __server_wait_variable__
}
diff --git a/tests/socket.test b/tests/socket.test
index 54b92ed..e263c57 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: socket.test,v 1.43.2.1 2010/09/28 15:43:01 kennykb Exp $
+# RCS: @(#) $Id: socket.test,v 1.43.2.2 2010/12/01 16:42:37 kennykb Exp $
# Running socket tests with a remote server:
# ------------------------------------------
@@ -92,13 +92,31 @@ if {![info exists remoteServerPort]} {
}
}
+if 0 {
+ # activate this to time the tests
+ proc test {args} {
+ set name [lindex $args 0]
+ puts "[lindex [time {uplevel [linsert $args 0 tcltest::test]}] 0] @@@ $name"
+ }
+}
+
+foreach {af localhost} {
+ any 127.0.0.1
+ inet 127.0.0.1
+ inet6 ::1
+} {
+ set ::tcl::unsupported::socketAF $af
+ # Check if the family is supported and set the constraint accordingly
+ testConstraint supported_$af [expr {![catch {socket -server foo 0} sock]}]
+ catch {close $sock}
+
#
# Check if we're supposed to do tests against the remote server
#
set doTestsWithRemoteServer 1
if {![info exists remoteServerIP]} {
- set remoteServerIP 127.0.0.1
+ set remoteServerIP $localhost
}
if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} {
set remoteServerPort [randport]
@@ -123,7 +141,7 @@ if {$doTestsWithRemoteServer} {
set noRemoteTestReason "can't exec"
set doTestsWithRemoteServer 0
} else {
- set remoteServerIP 127.0.0.1
+ set remoteServerIP $localhost
# Be *extra* careful in case this file is sourced from
# a directory other than the current one...
set remoteFile [file join [pwd] [file dirname [info script]] \
@@ -133,7 +151,7 @@ if {$doTestsWithRemoteServer} {
[interpreter] $remoteFile -serverIsSilent \
-port $remoteServerPort -address $remoteServerIP]" w+]
} msg]} then {
- after 1000
+ gets $remoteProcChan
if {[catch {
set commandSocket [socket $remoteServerIP $remoteServerPort]
} msg] == 0} then {
@@ -198,52 +216,52 @@ proc getPort sock {
# ----------------------------------------------------------------------
-test socket-1.1 {arg parsing for socket command} -constraints socket -body {
+test socket_$af-1.1 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -server
} -returnCodes error -result {no argument given for -server option}
-test socket-1.2 {arg parsing for socket command} -constraints socket -body {
+test socket_$af-1.2 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -server foo
} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
-test socket-1.3 {arg parsing for socket command} -constraints socket -body {
+test socket_$af-1.3 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -myaddr
} -returnCodes error -result {no argument given for -myaddr option}
-test socket-1.4 {arg parsing for socket command} -constraints socket -body {
- socket -myaddr 127.0.0.1
+test socket_$af-1.4 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
+ socket -myaddr $localhost
} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
-test socket-1.5 {arg parsing for socket command} -constraints socket -body {
+test socket_$af-1.5 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -myport
} -returnCodes error -result {no argument given for -myport option}
-test socket-1.6 {arg parsing for socket command} -constraints socket -body {
+test socket_$af-1.6 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -myport xxxx
} -returnCodes error -result {expected integer but got "xxxx"}
-test socket-1.7 {arg parsing for socket command} -constraints socket -body {
+test socket_$af-1.7 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -myport 2522
} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
-test socket-1.8 {arg parsing for socket command} -constraints socket -body {
+test socket_$af-1.8 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -froboz
} -returnCodes error -result {bad option "-froboz": must be -async, -myaddr, -myport, or -server}
-test socket-1.9 {arg parsing for socket command} -constraints socket -body {
+test socket_$af-1.9 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -server foo -myport 2521 3333
} -returnCodes error -result {option -myport is not valid for servers}
-test socket-1.10 {arg parsing for socket command} -constraints socket -body {
+test socket_$af-1.10 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket host 2528 -junk
} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
-test socket-1.11 {arg parsing for socket command} -constraints socket -body {
+test socket_$af-1.11 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -server callback 2520 --
} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
-test socket-1.12 {arg parsing for socket command} -constraints socket -body {
+test socket_$af-1.12 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket foo badport
} -returnCodes error -result {expected integer but got "badport"}
-test socket-1.13 {arg parsing for socket command} -constraints socket -body {
+test socket_$af-1.13 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -async -server
} -returnCodes error -result {cannot set -async option for server sockets}
-test socket-1.14 {arg parsing for socket command} -constraints socket -body {
+test socket_$af-1.14 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -server foo -async
} -returnCodes error -result {cannot set -async option for server sockets}
set path(script) [makeFile {} script]
-test socket-2.1 {tcp connection} -constraints {socket stdio} -setup {
+test socket_$af-2.1 {tcp connection} -constraints [list socket supported_$af stdio] -setup {
file delete $path(script)
set f [open $path(script) w]
puts $f {
@@ -267,14 +285,14 @@ test socket-2.1 {tcp connection} -constraints {socket stdio} -setup {
gets $f listen
} -body {
# $x == "ready" at this point
- set sock [socket 127.0.0.1 $listen]
+ set sock [socket $localhost $listen]
lappend x [gets $f]
close $sock
lappend x [gets $f]
} -cleanup {
close $f
} -result {ready done {}}
-test socket-2.2 {tcp connection with client port specified} -setup {
+test socket_$af-2.2 {tcp connection with client port specified} -setup {
set port [randport]
file delete $path(script)
set f [open $path(script) w]
@@ -297,19 +315,19 @@ test socket-2.2 {tcp connection with client port specified} -setup {
set f [open "|[list [interpreter] $path(script)]" r]
gets $f x
gets $f listen
-} -constraints {socket stdio} -body {
+} -constraints [list socket supported_$af stdio] -body {
# $x == "ready" at this point
- set sock [socket -myport $port 127.0.0.1 $listen]
+ set sock [socket -myport $port $localhost $listen]
puts $sock hello
flush $sock
lappend x [expr {[gets $f] eq "hello $port"}]
close $sock
return $x
} -cleanup {
- catch {close [socket 127.0.0.1 $listen]}
+ catch {close [socket $localhost $listen]}
close $f
} -result {ready 1}
-test socket-2.3 {tcp connection with client interface specified} -setup {
+test socket_$af-2.3 {tcp connection with client interface specified} -setup {
file delete $path(script)
set f [open $path(script) w]
puts $f {
@@ -331,9 +349,9 @@ test socket-2.3 {tcp connection with client interface specified} -setup {
set f [open "|[list [interpreter] $path(script)]" r]
gets $f listen
gets $f x
-} -constraints {socket stdio} -body {
+} -constraints [list socket supported_$af stdio] -body {
# $x == "ready" at this point
- set sock [socket -myaddr 127.0.0.1 127.0.0.1 $listen]
+ set sock [socket -myaddr $localhost $localhost $listen]
puts $sock hello
flush $sock
lappend x [gets $f]
@@ -341,13 +359,14 @@ test socket-2.3 {tcp connection with client interface specified} -setup {
return $x
} -cleanup {
close $f
-} -result {ready {hello 127.0.0.1}}
-test socket-2.4 {tcp connection with server interface specified} -setup {
+} -result [list ready [list hello $localhost]]
+test socket_$af-2.4 {tcp connection with server interface specified} -setup {
file delete $path(script)
set f [open $path(script) w]
+ puts $f [list set localhost $localhost]
puts $f {
set timer [after 2000 "set x done"]
- set f [socket -server accept -myaddr 127.0.0.1 0]
+ set f [socket -server accept -myaddr $localhost 0]
proc accept {file addr port} {
global x
puts "[gets $file]"
@@ -364,9 +383,9 @@ test socket-2.4 {tcp connection with server interface specified} -setup {
set f [open "|[list [interpreter] $path(script)]" r]
gets $f x
gets $f listen
-} -constraints {socket stdio} -body {
+} -constraints [list socket supported_$af stdio] -body {
# $x == "ready" at this point
- set sock [socket 127.0.0.1 $listen]
+ set sock [socket $localhost $listen]
puts $sock hello
flush $sock
lappend x [gets $f]
@@ -375,7 +394,7 @@ test socket-2.4 {tcp connection with server interface specified} -setup {
} -cleanup {
close $f
} -result {ready hello}
-test socket-2.5 {tcp connection with redundant server port} -setup {
+test socket_$af-2.5 {tcp connection with redundant server port} -setup {
file delete $path(script)
set f [open $path(script) w]
puts $f {
@@ -397,9 +416,9 @@ test socket-2.5 {tcp connection with redundant server port} -setup {
set f [open "|[list [interpreter] $path(script)]" r]
gets $f x
gets $f listen
-} -constraints {socket stdio} -body {
+} -constraints [list socket supported_$af stdio] -body {
# $x == "ready" at this point
- set sock [socket 127.0.0.1 $listen]
+ set sock [socket $localhost $listen]
puts $sock hello
flush $sock
lappend x [gets $f]
@@ -408,9 +427,9 @@ test socket-2.5 {tcp connection with redundant server port} -setup {
} -cleanup {
close $f
} -result {ready hello}
-test socket-2.6 {tcp connection} -constraints socket -body {
+test socket_$af-2.6 {tcp connection} -constraints [list socket supported_$af] -body {
set status ok
- if {![catch {set sock [socket 127.0.0.1 [randport]]}]} {
+ if {![catch {set sock [socket $localhost [randport]]}]} {
if {![catch {gets $sock}]} {
set status broken
}
@@ -418,7 +437,7 @@ test socket-2.6 {tcp connection} -constraints socket -body {
}
set status
} -result ok
-test socket-2.7 {echo server, one line} -constraints {socket stdio} -setup {
+test socket_$af-2.7 {echo server, one line} -constraints [list socket supported_$af stdio] -setup {
file delete $path(script)
set f [open $path(script) w]
puts $f {
@@ -450,10 +469,9 @@ test socket-2.7 {echo server, one line} -constraints {socket stdio} -setup {
gets $f
gets $f listen
} -body {
- set s [socket 127.0.0.1 $listen]
+ set s [socket $localhost $listen]
fconfigure $s -buffering line -translation lf
puts $s "hello abcdefghijklmnop"
- after 1000
set x [gets $s]
close $s
list $x [gets $f]
@@ -461,7 +479,7 @@ test socket-2.7 {echo server, one line} -constraints {socket stdio} -setup {
close $f
} -result {{hello abcdefghijklmnop} done}
removeFile script
-test socket-2.8 {echo server, loop 50 times, single connection} -setup {
+test socket_$af-2.8 {echo server, loop 50 times, single connection} -setup {
set path(script) [makeFile {
set f [socket -server accept 0]
proc accept {s a p} {
@@ -492,8 +510,8 @@ test socket-2.8 {echo server, loop 50 times, single connection} -setup {
set f [open "|[list [interpreter] $path(script)]" r]
gets $f
gets $f listen
-} -constraints {socket stdio} -body {
- set s [socket 127.0.0.1 $listen]
+} -constraints [list socket supported_$af stdio] -body {
+ set s [socket $localhost $listen]
fconfigure $s -buffering line
catch {
for {set x 0} {$x < 50} {incr x} {
@@ -509,11 +527,12 @@ test socket-2.8 {echo server, loop 50 times, single connection} -setup {
removeFile script
} -result {done 50}
set path(script) [makeFile {} script]
-test socket-2.9 {socket conflict} -constraints {socket stdio} -body {
+test socket_$af-2.9 {socket conflict} -constraints [list socket supported_$af stdio] -body {
set s [socket -server accept 0]
file delete $path(script)
set f [open $path(script) w]
- puts -nonewline $f "socket -server accept [lindex [fconfigure $s -sockname] 2]"
+ puts $f [list set ::tcl::unsupported::socketAF $::tcl::unsupported::socketAF]
+ puts $f "socket -server accept [lindex [fconfigure $s -sockname] 2]"
close $f
set f [open "|[list [interpreter] $path(script)]" r]
gets $f
@@ -522,10 +541,10 @@ test socket-2.9 {socket conflict} -constraints {socket stdio} -body {
} -returnCodes error -cleanup {
close $s
} -match glob -result {couldn't open socket: address already in use*}
-test socket-2.10 {close on accept, accepted socket lives} -setup {
+test socket_$af-2.10 {close on accept, accepted socket lives} -setup {
set done 0
set timer [after 20000 "set done timed_out"]
-} -constraints socket -body {
+} -constraints [list socket supported_$af] -body {
set ss [socket -server accept 0]
proc accept {s a p} {
global ss
@@ -539,7 +558,7 @@ test socket-2.10 {close on accept, accepted socket lives} -setup {
close $s
set done 1
}
- set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
+ set cs [socket $localhost [lindex [fconfigure $ss -sockname] 2]]
puts $cs hello
close $cs
vwait done
@@ -547,7 +566,7 @@ test socket-2.10 {close on accept, accepted socket lives} -setup {
} -cleanup {
after cancel $timer
} -result 1
-test socket-2.11 {detecting new data} -constraints socket -setup {
+test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$af] -setup {
proc accept {s a p} {
global sock
set sock $s
@@ -555,18 +574,20 @@ test socket-2.11 {detecting new data} -constraints socket -setup {
set s [socket -server accept 0]
set sock ""
} -body {
- set s2 [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
+ set s2 [socket $localhost [lindex [fconfigure $s -sockname] 2]]
vwait sock
puts $s2 one
flush $s2
- after 500
+ after idle {set x 1}
+ vwait x
fconfigure $sock -blocking 0
set result a:[gets $sock]
lappend result b:[gets $sock]
fconfigure $sock -blocking 1
puts $s2 two
flush $s2
- after 500
+ after idle {set x 1}
+ vwait x
fconfigure $sock -blocking 0
lappend result c:[gets $sock]
} -cleanup {
@@ -576,11 +597,12 @@ test socket-2.11 {detecting new data} -constraints socket -setup {
close $sock
} -result {a:one b: c:two}
-test socket-3.1 {socket conflict} -constraints {socket stdio} -setup {
+test socket_$af-3.1 {socket conflict} -constraints [list socket supported_$af stdio] -setup {
file delete $path(script)
set f [open $path(script) w]
+ puts $f [list set localhost $localhost]
puts $f {
- set f [socket -server accept -myaddr 127.0.0.1 0]
+ set f [socket -server accept -myaddr $localhost 0]
puts ready
puts [lindex [fconfigure $f -sockname] 2]
gets stdin
@@ -591,20 +613,21 @@ test socket-3.1 {socket conflict} -constraints {socket stdio} -setup {
gets $f
gets $f listen
} -body {
- socket -server accept -myaddr 127.0.0.1 $listen
+ socket -server accept -myaddr $localhost $listen
} -cleanup {
puts $f bye
close $f
} -returnCodes error -result {couldn't open socket: address already in use}
-test socket-3.2 {server with several clients} -setup {
+test socket_$af-3.2 {server with several clients} -setup {
file delete $path(script)
set f [open $path(script) w]
+ puts $f [list set localhost $localhost]
puts $f {
set t1 [after 30000 "set x timed_out"]
set t2 [after 31000 "set x timed_out"]
set t3 [after 32000 "set x timed_out"]
set counter 0
- set s [socket -server accept -myaddr 127.0.0.1 0]
+ set s [socket -server accept -myaddr $localhost 0]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line
@@ -634,13 +657,13 @@ test socket-3.2 {server with several clients} -setup {
set f [open "|[list [interpreter] $path(script)]" r+]
set x [gets $f]
gets $f listen
-} -constraints {socket stdio} -body {
+} -constraints [list socket supported_$af stdio] -body {
# $x == "ready" here
- set s1 [socket 127.0.0.1 $listen]
+ set s1 [socket $localhost $listen]
fconfigure $s1 -buffering line
- set s2 [socket 127.0.0.1 $listen]
+ set s2 [socket $localhost $listen]
fconfigure $s2 -buffering line
- set s3 [socket 127.0.0.1 $listen]
+ set s3 [socket $localhost $listen]
fconfigure $s3 -buffering line
for {set i 0} {$i < 100} {incr i} {
puts $s1 hello,s1
@@ -658,12 +681,13 @@ test socket-3.2 {server with several clients} -setup {
close $f
} -result {ready done}
-test socket-4.1 {server with several clients} -setup {
+test socket_$af-4.1 {server with several clients} -setup {
file delete $path(script)
set f [open $path(script) w]
+ puts $f [list set localhost $localhost]
puts $f {
set port [gets stdin]
- set s [socket 127.0.0.1 $port]
+ set s [socket $localhost $port]
fconfigure $s -buffering line
for {set i 0} {$i < 100} {incr i} {
puts $s hello
@@ -680,7 +704,7 @@ test socket-4.1 {server with several clients} -setup {
fconfigure $p2 -buffering line
set p3 [open "|[list [interpreter] $path(script)]" r+]
fconfigure $p3 -buffering line
-} -constraints {socket stdio} -body {
+} -constraints [list socket supported_$af stdio] -body {
proc accept {s a p} {
fconfigure $s -buffering line
fileevent $s readable [list echo $s]
@@ -698,7 +722,7 @@ test socket-4.1 {server with several clients} -setup {
set t1 [after 30000 "set x timed_out"]
set t2 [after 31000 "set x timed_out"]
set t3 [after 32000 "set x timed_out"]
- set s [socket -server accept -myaddr 127.0.0.1 0]
+ set s [socket -server accept -myaddr $localhost 0]
set listen [lindex [fconfigure $s -sockname] 2]
puts $p1 $listen
puts $p2 $listen
@@ -722,34 +746,34 @@ test socket-4.1 {server with several clients} -setup {
close $p2
close $p3
} -result {{p1 bye done} {p2 bye done} {p3 bye done}}
-test socket-4.2 {byte order problems, socket numbers, htons} -body {
- close [socket -server dodo -myaddr 127.0.0.1 0x3000]
+test socket_$af-4.2 {byte order problems, socket numbers, htons} -body {
+ close [socket -server dodo -myaddr $localhost 0x3000]
return ok
-} -constraints socket -result ok
+} -constraints [list socket supported_$af] -result ok
-test socket-5.1 {byte order problems, socket numbers, htons} -body {
+test socket_$af-5.1 {byte order problems, socket numbers, htons} -body {
if {![catch {socket -server dodo 0x1} msg]} {
close $msg
return {htons problem, should be disallowed, are you running as SU?}
}
return {couldn't open socket: not owner}
-} -constraints {socket unix notRoot} -result {couldn't open socket: not owner}
-test socket-5.2 {byte order problems, socket numbers, htons} -body {
+} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner}
+test socket_$af-5.2 {byte order problems, socket numbers, htons} -body {
if {![catch {socket -server dodo 0x10000} msg]} {
close $msg
return {port resolution problem, should be disallowed}
}
return {couldn't open socket: port number too high}
-} -constraints socket -result {couldn't open socket: port number too high}
-test socket-5.3 {byte order problems, socket numbers, htons} -body {
+} -constraints [list socket supported_$af] -result {couldn't open socket: port number too high}
+test socket_$af-5.3 {byte order problems, socket numbers, htons} -body {
if {![catch {socket -server dodo 21} msg]} {
close $msg
return {htons problem, should be disallowed, are you running as SU?}
}
return {couldn't open socket: not owner}
-} -constraints {socket unix notRoot} -result {couldn't open socket: not owner}
+} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner}
-test socket-6.1 {accept callback error} -constraints {socket stdio} -setup {
+test socket_$af-6.1 {accept callback error} -constraints [list socket supported_$af stdio] -setup {
proc myHandler {msg options} {
variable x $msg
}
@@ -758,14 +782,15 @@ test socket-6.1 {accept callback error} -constraints {socket stdio} -setup {
file delete $path(script)
} -body {
set f [open $path(script) w]
+ puts $f [list set localhost $localhost]
puts $f {
gets stdin port
- socket 127.0.0.1 $port
+ socket $localhost $port
}
close $f
set f [open "|[list [interpreter] $path(script)]" r+]
proc accept {s a p} {expr 10 / 0}
- set s [socket -server accept -myaddr 127.0.0.1 0]
+ set s [socket -server accept -myaddr $localhost 0]
puts $f [lindex [fconfigure $s -sockname] 2]
close $f
set timer [after 10000 "set x timed_out"]
@@ -777,7 +802,7 @@ test socket-6.1 {accept callback error} -constraints {socket stdio} -setup {
interp bgerror {} $handler
} -result {divide by zero}
-test socket-7.1 {testing socket specific options} -setup {
+test socket_$af-7.1 {testing socket specific options} -setup {
file delete $path(script)
set f [open $path(script) w]
puts $f {
@@ -797,19 +822,20 @@ test socket-7.1 {testing socket specific options} -setup {
gets $f
gets $f listen
set l ""
-} -constraints {socket stdio} -body {
- set s [socket 127.0.0.1 $listen]
+} -constraints [list socket supported_$af stdio] -body {
+ set s [socket $localhost $listen]
set p [fconfigure $s -peername]
close $s
- lappend l [string compare [lindex $p 0] 127.0.0.1]
+ lappend l [string compare [lindex $p 0] $localhost]
lappend l [string compare [lindex $p 2] $listen]
lappend l [llength $p]
} -cleanup {
close $f
} -result {0 0 3}
-test socket-7.2 {testing socket specific options} -setup {
+test socket_$af-7.2 {testing socket specific options} -setup {
file delete $path(script)
set f [open $path(script) w]
+ puts $f [list set ::tcl::unsupported::socketAF $::tcl::unsupported::socketAF]
puts $f {
set ss [socket -server accept 0]
proc accept args {
@@ -826,35 +852,35 @@ test socket-7.2 {testing socket specific options} -setup {
set f [open "|[list [interpreter] $path(script)]" r]
gets $f
gets $f listen
-} -constraints {socket stdio} -body {
- set s [socket 127.0.0.1 $listen]
+} -constraints [list socket supported_$af stdio] -body {
+ set s [socket $localhost $listen]
set p [fconfigure $s -sockname]
close $s
list [llength $p] \
- [regexp {^(127\.0\.0\.1|0\.0\.0\.0)$} [lindex $p 0]] \
+ [regexp {^(127\.0\.0\.1|0\.0\.0\.0|::1)$} [lindex $p 0]] \
[expr {[lindex $p 2] == $listen}]
} -cleanup {
close $f
} -result {3 1 0}
-test socket-7.3 {testing socket specific options} -constraints socket -body {
- set s [socket -server accept -myaddr 127.0.0.1 0]
+test socket_$af-7.3 {testing socket specific options} -constraints [list socket supported_$af] -body {
+ set s [socket -server accept -myaddr $localhost 0]
set l [fconfigure $s]
close $s
update
llength $l
} -result 14
-test socket-7.4 {testing socket specific options} -constraints socket -setup {
+test socket_$af-7.4 {testing socket specific options} -constraints [list socket supported_$af] -setup {
set timer [after 10000 "set x timed_out"]
set l ""
} -body {
- set s [socket -server accept -myaddr 127.0.0.1 0]
+ set s [socket -server accept -myaddr $localhost 0]
proc accept {s a p} {
global x
set x [fconfigure $s -sockname]
close $s
}
set listen [lindex [fconfigure $s -sockname] 2]
- set s1 [socket 127.0.0.1 $listen]
+ set s1 [socket $localhost $listen]
vwait x
lappend l [expr {[lindex $x 2] == $listen}] [llength $x]
} -cleanup {
@@ -862,10 +888,10 @@ test socket-7.4 {testing socket specific options} -constraints socket -setup {
close $s
close $s1
} -result {1 3}
-test socket-7.5 {testing socket specific options} -setup {
+test socket_$af-7.5 {testing socket specific options} -setup {
set timer [after 10000 "set x timed_out"]
set l ""
-} -constraints {socket unixOrPc} -body {
+} -constraints [list socket supported_$af unixOrPc] -body {
set s [socket -server accept 0]
proc accept {s a p} {
global x
@@ -873,16 +899,16 @@ test socket-7.5 {testing socket specific options} -setup {
close $s
}
set listen [lindex [fconfigure $s -sockname] 2]
- set s1 [socket 127.0.0.1 $listen]
+ set s1 [socket $localhost $listen]
vwait x
lappend l [lindex $x 0] [expr {[lindex $x 2] == $listen}] [llength $x]
} -cleanup {
after cancel $timer
close $s
close $s1
-} -result {127.0.0.1 1 3}
+} -result [list $localhost 1 3]
-test socket-8.1 {testing -async flag on sockets} -constraints socket -body {
+test socket_$af-8.1 {testing -async flag on sockets} -constraints [list socket supported_$af] -body {
# NOTE: This test may fail on some Solaris 2.4 systems. If it does, check
# that you have these patches installed (using showrev -p):
#
@@ -897,14 +923,14 @@ test socket-8.1 {testing -async flag on sockets} -constraints socket -body {
# please email jyl@eng.sun.com. We have not observed this failure on
# Solaris 2.5, so another option (instead of installing these patches) is
# to upgrade to Solaris 2.5.
- set s [socket -server accept -myaddr 127.0.0.1 0]
+ set s [socket -server accept -myaddr $localhost 0]
proc accept {s a p} {
global x
puts $s bye
close $s
set x done
}
- set s1 [socket -async 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
+ set s1 [socket -async $localhost [lindex [fconfigure $s -sockname] 2]]
vwait x
gets $s1
} -cleanup {
@@ -912,7 +938,7 @@ test socket-8.1 {testing -async flag on sockets} -constraints socket -body {
close $s1
} -result bye
-test socket-9.1 {testing spurious events} -constraints socket -setup {
+test socket_$af-9.1 {testing spurious events} -constraints [list socket supported_$af] -setup {
set len 0
set spurious 0
set done 0
@@ -936,8 +962,8 @@ test socket-9.1 {testing spurious events} -constraints socket -setup {
fconfigure $s -buffering none -blocking off
fileevent $s readable [list readlittle $s]
}
- set s [socket -server accept -myaddr 127.0.0.1 0]
- set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
+ set s [socket -server accept -myaddr $localhost 0]
+ set c [socket $localhost [lindex [fconfigure $s -sockname] 2]]
puts -nonewline $c 01234567890123456789012345678901234567890123456789
close $c
vwait done
@@ -946,7 +972,7 @@ test socket-9.1 {testing spurious events} -constraints socket -setup {
} -cleanup {
after cancel $timer
} -result {0 50}
-test socket-9.2 {testing async write, fileevents, flush on close} -constraints socket -setup {
+test socket_$af-9.2 {testing async write, fileevents, flush on close} -constraints [list socket supported_$af] -setup {
set firstblock ""
for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
set secondblock ""
@@ -954,7 +980,7 @@ test socket-9.2 {testing async write, fileevents, flush on close} -constraints s
set secondblock "b$secondblock$secondblock"
}
set timer [after 10000 "set done timed_out"]
- set l [socket -server accept -myaddr 127.0.0.1 0]
+ set l [socket -server accept -myaddr $localhost 0]
proc accept {s a p} {
fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
-buffering line
@@ -963,12 +989,12 @@ test socket-9.2 {testing async write, fileevents, flush on close} -constraints s
proc readable {s} {
set l [gets $s]
fileevent $s readable {}
- after 1000 respond $s
+ after idle respond $s
}
proc respond {s} {
global firstblock
puts -nonewline $s $firstblock
- after 1000 writedata $s
+ after idle writedata $s
}
proc writedata {s} {
global secondblock
@@ -976,7 +1002,7 @@ test socket-9.2 {testing async write, fileevents, flush on close} -constraints s
close $s
}
} -body {
- set s [socket 127.0.0.1 [lindex [fconfigure $l -sockname] 2]]
+ set s [socket $localhost [lindex [fconfigure $l -sockname] 2]]
fconfigure $s -blocking 0 -trans lf -buffering line
set count 0
puts $s hello
@@ -996,7 +1022,7 @@ test socket-9.2 {testing async write, fileevents, flush on close} -constraints s
close $l
after cancel $timer
} -result 65566
-test socket-9.3 {testing EOF stickyness} -constraints socket -setup {
+test socket_$af-9.3 {testing EOF stickyness} -constraints [list socket supported_$af] -setup {
set count 0
set done false
proc write_then_close {s} {
@@ -1007,7 +1033,7 @@ test socket-9.3 {testing EOF stickyness} -constraints socket -setup {
fconfigure $s -buffering line -translation lf
fileevent $s writable "write_then_close $s"
}
- set s [socket -server accept -myaddr 127.0.0.1 0]
+ set s [socket -server accept -myaddr $localhost 0]
} -body {
proc count_to_eof {s} {
global count done
@@ -1027,7 +1053,7 @@ test socket-9.3 {testing EOF stickyness} -constraints socket -setup {
set count {timer went off, eof is not sticky}
close $s
}
- set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
+ set c [socket $localhost [lindex [fconfigure $s -sockname] 2]]
fconfigure $c -blocking off -buffering line -translation lf
fileevent $c readable "count_to_eof $c"
set timer [after 1000 timerproc $c]
@@ -1040,9 +1066,8 @@ test socket-9.3 {testing EOF stickyness} -constraints socket -setup {
removeFile script
-test socket-10.1 {testing socket accept callback error handling} -constraints {
- socket
-} -setup {
+test socket_$af-10.1 {testing socket accept callback error handling} \
+ -constraints [list socket supported_$af] -setup {
variable goterror 0
proc myHandler {msg options} {
variable goterror 1
@@ -1050,9 +1075,9 @@ test socket-10.1 {testing socket accept callback error handling} -constraints {
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
} -body {
- set s [socket -server accept -myaddr 127.0.0.1 0]
+ set s [socket -server accept -myaddr $localhost 0]
proc accept {s a p} {close $s; error}
- set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
+ set c [socket $localhost [lindex [fconfigure $s -sockname] 2]]
vwait goterror
close $s
close $c
@@ -1061,7 +1086,7 @@ test socket-10.1 {testing socket accept callback error handling} -constraints {
interp bgerror {} $handler
} -result 1
-test socket-11.1 {tcp connection} -setup {
+test socket_$af-11.1 {tcp connection} -setup {
set port [sendCommand {
set server [socket -server accept 0]
proc accept {s a p} {
@@ -1070,14 +1095,14 @@ test socket-11.1 {tcp connection} -setup {
}
getPort $server
}]
-} -constraints {socket doTestsWithRemoteServer} -body {
+} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
set s [socket $remoteServerIP $port]
gets $s
} -cleanup {
close $s
sendCommand {close $server}
} -result done
-test socket-11.2 {client specifies its port} -setup {
+test socket_$af-11.2 {client specifies its port} -setup {
set lport [randport]
set rport [sendCommand {
set server [socket -server accept 0]
@@ -1087,7 +1112,7 @@ test socket-11.2 {client specifies its port} -setup {
}
getPort $server
}]
-} -constraints {socket doTestsWithRemoteServer} -body {
+} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
set s [socket -myport $lport $remoteServerIP $rport]
set r [gets $s]
expr {$r==$lport ? "ok" : "broken: $r != $port"}
@@ -1095,7 +1120,7 @@ test socket-11.2 {client specifies its port} -setup {
close $s
sendCommand {close $server}
} -result ok
-test socket-11.3 {trying to connect, no server} -body {
+test socket_$af-11.3 {trying to connect, no server} -body {
set status ok
if {![catch {set s [socket $remoteServerIp [randport]]}]} {
if {![catch {gets $s}]} {
@@ -1104,8 +1129,8 @@ test socket-11.3 {trying to connect, no server} -body {
close $s
}
return $status
-} -constraints {socket doTestsWithRemoteServer} -result ok
-test socket-11.4 {remote echo, one line} -setup {
+} -constraints [list socket supported_$af doTestsWithRemoteServer] -result ok
+test socket_$af-11.4 {remote echo, one line} -setup {
set port [sendCommand {
set server [socket -server accept 0]
proc accept {s a p} {
@@ -1122,7 +1147,7 @@ test socket-11.4 {remote echo, one line} -setup {
}
getPort $server
}]
-} -constraints {socket doTestsWithRemoteServer} -body {
+} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
set f [socket $remoteServerIP $port]
fconfigure $f -translation crlf -buffering line
puts $f hello
@@ -1131,7 +1156,7 @@ test socket-11.4 {remote echo, one line} -setup {
catch {close $f}
sendCommand {close $server}
} -result hello
-test socket-11.5 {remote echo, 50 lines} -setup {
+test socket_$af-11.5 {remote echo, 50 lines} -setup {
set port [sendCommand {
set server [socket -server accept 0]
proc accept {s a p} {
@@ -1148,7 +1173,7 @@ test socket-11.5 {remote echo, 50 lines} -setup {
}
getPort $server
}]
-} -constraints {socket doTestsWithRemoteServer} -body {
+} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
set f [socket $remoteServerIP $port]
fconfigure $f -translation crlf -buffering line
for {set cnt 0} {$cnt < 50} {incr cnt} {
@@ -1162,15 +1187,15 @@ test socket-11.5 {remote echo, 50 lines} -setup {
close $f
sendCommand {close $server}
} -result 50
-test socket-11.6 {socket conflict} -setup {
- set s1 [socket -server accept -myaddr 127.0.0.1 0]
-} -constraints {socket doTestsWithRemoteServer} -body {
- set s2 [socket -server accept -myaddr 127.0.0.1 [getPort $s1]]
+test socket_$af-11.6 {socket conflict} -setup {
+ set s1 [socket -server accept -myaddr $localhost 0]
+} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
+ set s2 [socket -server accept -myaddr $localhost [getPort $s1]]
list [getPort $s2] [close $s2]
} -cleanup {
close $s1
} -returnCodes error -result {couldn't open socket: address already in use}
-test socket-11.7 {server with several clients} -setup {
+test socket_$af-11.7 {server with several clients} -setup {
set port [sendCommand {
set server [socket -server accept 0]
proc accept {s a p} {
@@ -1187,7 +1212,7 @@ test socket-11.7 {server with several clients} -setup {
}
getPort $server
}]
-} -constraints {socket doTestsWithRemoteServer} -body {
+} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
set s1 [socket $remoteServerIP $port]
fconfigure $s1 -buffering line
set s2 [socket $remoteServerIP $port]
@@ -1209,7 +1234,7 @@ test socket-11.7 {server with several clients} -setup {
close $s3
sendCommand {close $server}
} -result 100
-test socket-11.8 {client with several servers} -setup {
+test socket_$af-11.8 {client with several servers} -setup {
lassign [sendCommand {
set s1 [socket -server "accept server1" 0]
set s2 [socket -server "accept server2" 0]
@@ -1220,7 +1245,7 @@ test socket-11.8 {client with several servers} -setup {
}
list [getPort $s1] [getPort $s2] [getPort $s3]
}] p1 p2 p3
-} -constraints {socket doTestsWithRemoteServer} -body {
+} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
set s1 [socket $remoteServerIP $p1]
set s2 [socket $remoteServerIP $p2]
set s3 [socket $remoteServerIP $p3]
@@ -1236,9 +1261,7 @@ test socket-11.8 {client with several servers} -setup {
close $s3
}
} -result {server1 {} 1 server2 {} 1 server3 {} 1}
-test socket-11.9 {accept callback error} -constraints {
- socket doTestsWithRemoteServer
-} -setup {
+test socket_$af-11.9 {accept callback error} -constraints [list socket supported_$af doTestsWithRemoteServer] -setup {
proc myHandler {msg options} {
variable x $msg
}
@@ -1266,13 +1289,13 @@ test socket-11.9 {accept callback error} -constraints {
after cancel $timer
interp bgerror {} $handler
} -result {divide by zero}
-test socket-11.10 {testing socket specific options} -setup {
+test socket_$af-11.10 {testing socket specific options} -setup {
set port [sendCommand {
set server [socket -server accept 0]
proc accept {s a p} {close $s}
getPort $server
}]
-} -constraints {socket doTestsWithRemoteServer} -body {
+} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
set s [socket $remoteServerIP $port]
set p [fconfigure $s -peername]
set n [fconfigure $s -sockname]
@@ -1281,12 +1304,12 @@ test socket-11.10 {testing socket specific options} -setup {
close $s
sendCommand {close $server}
} -result {1 3 3}
-test socket-11.11 {testing spurious events} -setup {
+test socket_$af-11.11 {testing spurious events} -setup {
set port [sendCommand {
set server [socket -server accept 0]
proc accept {s a p} {
fconfigure $s -translation "auto lf"
- after 100 writesome $s
+ after idle writesome $s
}
proc writesome {s} {
for {set i 0} {$i < 100} {incr i} {
@@ -1300,7 +1323,7 @@ test socket-11.11 {testing spurious events} -setup {
set spurious 0
set done 0
set timer [after 40000 "set done timed_out"]
-} -constraints {socket doTestsWithRemoteServer} -body {
+} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
proc readlittle {s} {
global spurious done len
set l [read $s 1]
@@ -1323,13 +1346,13 @@ test socket-11.11 {testing spurious events} -setup {
after cancel $timer
sendCommand {close $server}
} -result {0 2690 1}
-test socket-11.12 {testing EOF stickyness} -constraints {socket doTestsWithRemoteServer} -setup {
+test socket_$af-11.12 {testing EOF stickyness} -constraints [list socket supported_$af doTestsWithRemoteServer] -setup {
set counter 0
set done 0
set port [sendCommand {
set server [socket -server accept 0]
proc accept {s a p} {
- after 100 close $s
+ after idle close $s
}
getPort $server
}]
@@ -1359,7 +1382,7 @@ test socket-11.12 {testing EOF stickyness} -constraints {socket doTestsWithRemot
after cancel $after_id
sendCommand {close $server}
} -result {EOF is sticky}
-test socket-11.13 {testing async write, async flush, async close} -setup {
+test socket_$af-11.13 {testing async write, async flush, async close} -setup {
set port [sendCommand {
set firstblock ""
for {set i 0} {$i < 5} {incr i} {
@@ -1378,12 +1401,12 @@ test socket-11.13 {testing async write, async flush, async close} -setup {
proc readable {s} {
set l [gets $s]
fileevent $s readable {}
- after 1000 respond $s
+ after idle respond $s
}
proc respond {s} {
global firstblock
puts -nonewline $s $firstblock
- after 1000 writedata $s
+ after idle writedata $s
}
proc writedata {s} {
global secondblock
@@ -1393,7 +1416,7 @@ test socket-11.13 {testing async write, async flush, async close} -setup {
getPort $l
}]
set timer [after 10000 "set done timed_out"]
-} -constraints {socket doTestsWithRemoteServer} -body {
+} -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
proc readit {s} {
global count done
set l [read $s]
@@ -1418,57 +1441,56 @@ test socket-11.13 {testing async write, async flush, async close} -setup {
set path(script1) [makeFile {} script1]
set path(script2) [makeFile {} script2]
-test socket-12.1 {testing inheritance of server sockets} -setup {
+test socket_$af-12.1 {testing inheritance of server sockets} -setup {
file delete $path(script1)
file delete $path(script2)
# Script1 is just a 10 second delay. If the server socket is inherited, it
# will be held open for 10 seconds
set f [open $path(script1) w]
puts $f {
+ fileevent stdin readable exit
after 10000 exit
vwait forever
}
close $f
- # Script2 creates the server socket, launches script1, waits a second, and
- # exits. The server socket will now be closed unless script1 inherited it.
+ # Script2 creates the server socket, launches script1, and exits.
+ # The server socket will now be closed unless script1 inherited it.
set f [open $path(script2) w]
puts $f [list set tcltest [interpreter]]
puts $f [list set delay $path(script1)]
+ puts $f [list set localhost $localhost]
puts $f {
- set f [socket -server accept -myaddr 127.0.0.1 0]
- puts [lindex [fconfigure $f -sockname] 2]
+ set f [socket -server accept -myaddr $localhost 0]
proc accept { file addr port } {
close $file
}
exec $tcltest $delay &
+ puts [lindex [fconfigure $f -sockname] 2]
close $f
- after 1000 exit
- vwait forever
+ exit
}
close $f
-} -constraints {socket stdio exec} -body {
+} -constraints [list socket supported_$af stdio exec] -body {
# Launch script2 and wait 5 seconds
### exec [interpreter] script2 &
set p [open "|[list [interpreter] $path(script2)]" r]
- gets $p listen
- after 5000 { set ok_to_proceed 1 }
- vwait ok_to_proceed
# If we can still connect to the server, the socket got inherited.
- if {[catch {close [socket 127.0.0.1 $listen]}]} {
+ if {[catch {close [socket $localhost $listen]}]} {
return {server socket was not inherited}
} else {
return {server socket was inherited}
}
} -cleanup {
- close $p
+ catch {close $p}
} -result {server socket was not inherited}
-test socket-12.2 {testing inheritance of client sockets} -setup {
+test socket_$af-12.2 {testing inheritance of client sockets} -setup {
file delete $path(script1)
file delete $path(script2)
# Script1 is just a 20 second delay. If the server socket is inherited, it
# will be held open for 20 seconds
set f [open $path(script1) w]
puts $f {
+ fileevent stdin readable exit
after 20000 exit
vwait forever
}
@@ -1479,23 +1501,23 @@ test socket-12.2 {testing inheritance of client sockets} -setup {
set f [open $path(script2) w]
puts $f [list set tcltest [interpreter]]
puts $f [list set delay $path(script1)]
+ puts $f [list set localhost $localhost]
puts $f {
gets stdin port
- set f [socket 127.0.0.1 $port]
+ set f [socket $localhost $port]
exec $tcltest $delay &
puts $f testing
flush $f
- after 1000 exit
- vwait forever
+ exit
}
close $f
# If the socket doesn't hit end-of-file in 10 seconds, the script1 process
# must have inherited the client.
set failed 0
- after 10000 [list set failed 1]
-} -constraints {socket stdio exec} -body {
+ set after [after 10000 [list set failed 1]]
+} -constraints [list socket supported_$af stdio exec] -body {
# Create the server socket
- set server [socket -server accept -myaddr 127.0.0.1 0]
+ set server [socket -server accept -myaddr $localhost 0]
proc accept { file host port } {
# When the client connects, establish the read handler
global server
@@ -1531,16 +1553,15 @@ test socket-12.2 {testing inheritance of client sockets} -setup {
vwait x
return $x
} -cleanup {
- if {!$failed} {
- vwait failed
- }
+ after cancel $after
close $p
} -result {client socket was not inherited}
-test socket-12.3 {testing inheritance of accepted sockets} -setup {
+test socket_$af-12.3 {testing inheritance of accepted sockets} -setup {
file delete $path(script1)
file delete $path(script2)
set f [open $path(script1) w]
puts $f {
+ fileevent stdin readable exit
after 10000 exit
vwait forever
}
@@ -1548,27 +1569,26 @@ test socket-12.3 {testing inheritance of accepted sockets} -setup {
set f [open $path(script2) w]
puts $f [list set tcltest [interpreter]]
puts $f [list set delay $path(script1)]
+ puts $f [list set localhost $localhost]
puts $f {
- set server [socket -server accept -myaddr 127.0.0.1 0]
- puts stdout [lindex [fconfigure $server -sockname] 2]
+ set server [socket -server accept -myaddr $localhost 0]
proc accept { file host port } {
global tcltest delay
puts $file {test data on socket}
exec $tcltest $delay &
- after 1000 exit
+ after idle exit
}
+ puts stdout [lindex [fconfigure $server -sockname] 2]
vwait forever
}
close $f
-} -constraints {socket stdio exec} -body {
+} -constraints [list socket supported_$af stdio exec] -body {
# Launch the script2 process and connect to it. See how long the socket
# stays open
## exec [interpreter] script2 &
set p [open "|[list [interpreter] $path(script2)]" r]
gets $p listen
- after 1000 set ok_to_proceed 1
- vwait ok_to_proceed
- set f [socket 127.0.0.1 $listen]
+ set f [socket $localhost $listen]
fconfigure $f -buffering full -blocking 0
fileevent $f readable [list getdata $f]
# If the socket is still open after 5 seconds, the script1 process must
@@ -1604,10 +1624,10 @@ test socket-12.3 {testing inheritance of accepted sockets} -setup {
catch {close $p}
} -result {accepted socket was not inherited}
-test socket-13.1 {Testing use of shared socket between two threads} -setup {
+test socket_$af-13.1 {Testing use of shared socket between two threads} -setup {
threadReap
- set path(script) [makeFile {
- set f [socket -server accept -myaddr 127.0.0.1 0]
+ set path(script) [makeFile [string map [list @localhost@ $localhost] {
+ set f [socket -server accept -myaddr @localhost@ 0]
set listen [lindex [fconfigure $f -sockname] 2]
proc accept {s a p} {
fileevent $s readable [list echo $s]
@@ -1630,15 +1650,14 @@ test socket-13.1 {Testing use of shared socket between two threads} -setup {
close $f
# thread cleans itself up.
testthread exit
- } script]
-} -constraints {socket testthread} -body {
+ }] script]
+} -constraints [list socket supported_$af testthread] -body {
# create a thread
set serverthread [testthread create [list source $path(script) ] ]
update
set port [testthread send $serverthread {set listen}]
update
- after 1000
- set s [socket 127.0.0.1 $port]
+ set s [socket $localhost $port]
fconfigure $s -buffering line
catch {
puts $s "hello"
@@ -1646,7 +1665,6 @@ test socket-13.1 {Testing use of shared socket between two threads} -setup {
}
close $s
update
- after 2000
append result " " [threadReap]
} -cleanup {
removeFile script
@@ -1663,6 +1681,7 @@ if {$remoteProcChan ne ""} {
}
catch {close $commandSocket}
catch {close $remoteProcChan}
+}
::tcltest::cleanupTests
flush stdout
return
diff --git a/tests/util.test b/tests/util.test
index 994fc0f..bfb8507 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -7,13 +7,14 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: util.test,v 1.20 2008/10/14 16:35:44 dgp Exp $
+# RCS: @(#) $Id: util.test,v 1.20.6.1 2010/12/01 16:42:37 kennykb Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
+testConstraint controversialNaN 1
testConstraint testdstring [llength [info commands testdstring]]
testConstraint testconcatobj [llength [info commands testconcatobj]]
@@ -43,6 +44,10 @@ proc testIEEE {} {
ieeeValues(+Infinity)
binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
ieeeValues(NaN)
+ binary scan \x00\x00\x00\x00\x00\x00\xf8\xff d \
+ ieeeValues(-NaN)
+ binary scan \xef\xcd\xab\x89\x67\x45\xfb\xff d \
+ ieeeValues(-NaN(3456789abcdef))
set ieeeValues(littleEndian) 1
return 1
}
@@ -65,6 +70,10 @@ proc testIEEE {} {
ieeeValues(+Infinity)
binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
ieeeValues(NaN)
+ binary scan \xff\xf8\x00\x00\x00\x00\x00\x00 d \
+ ieeeValues(-NaN)
+ binary scan \xff\xfb\x45\x67\x89\xab\xcd\xef d \
+ ieeeValues(-NaN(3456789abcdef))
set ieeeValues(littleEndian) 0
return 1
}
@@ -85,6 +94,30 @@ proc convertDouble { x } {
return $result
}
+proc verdonk_test {sig binexp shouldbe exp} {
+ regexp {([-+]?)([0-9a-f]+)} $sig -> signum sig
+ scan $sig %llx sig
+ if {$signum eq {-}} {
+ set signum [expr 1<<63]
+ } else {
+ set signum 0
+ }
+ regexp {E([-+]?[0-9]+)} $binexp -> binexp
+ set word [expr {$signum | (($binexp + 0x3ff)<<52)|($sig & ~(1<<52))}]
+ binary scan [binary format w $word] q double
+ regexp {([-+])(\d+)_(\d+)\&} $shouldbe -> signum digits1 digits2
+ regexp {E([-+]\d+)} $exp -> decexp
+ incr decexp [expr {[string length $digits1] - 1}]
+ lassign [testdoubledigits $double [string length $digits1] e] \
+ outdigits decpt outsign
+ if {[string index $digits2 0] >= 5} {
+ incr digits1
+ }
+ if {$outsign != $signum || $outdigits != $digits1 || $decpt != $decexp} {
+ return -code error "result is ${outsign}0.${outdigits}E$decpt\
+ should be ${signum}0.${digits1}E$decexp"
+ }
+}
test util-1.1 {TclFindElement procedure - binary element in middle of list} {
lindex {0 foo\x00help 1} 1
@@ -1106,6 +1139,774 @@ test util-11.23 {Tcl_PrintDouble - scaling} {
expr 1.1e17
} {1.1e+17}
+test util-12.1 {TclDoubleDigits - Inf} ieeeFloatingPoint {
+ testdoubledigits Inf -1 shortest
+} {Infinity 9999 +}
+test util-12.2 {TclDoubleDigits - -Inf} ieeeFloatingPoint {
+ testdoubledigits -Inf -1 shortest
+} {Infinity 9999 -}
+test util-12.3 {TclDoubleDigits - NaN} ieeeFloatingPoint {
+ testdoubledigits $ieeeValues(NaN) -1 shortest
+} {NaN 9999 +}
+test util-12.4 {TclDoubleDigits - NaN} {*}{
+ -constraints {ieeeFloatingPoint && controversialNaN}
+ -body {
+ testdoubledigits -NaN -1 shortest
+ }
+ -result {NaN 9999 -}
+}
+test util-12.5 {TclDoubleDigits - 0} {
+ testdoubledigits 0.0 -1 shortest
+} {0 0 +}
+test util-12.6 {TclDoubleDigits - -0} {
+ testdoubledigits -0.0 -1 shortest
+} {0 0 -}
+
+# Verdonk test vectors
+
+test util-13.1 {just over exact - 1 digits} {*}{
+ -body {
+ verdonk_test 1754e31cd072da E+1008 +4_000000000000000000& E+303
+ }
+ -result {}
+}
+test util-13.2 {just over exact - 1 digits} {*}{
+ -body {
+ verdonk_test -1afcef51f0fb5f E+265 -1_000000000000000000& E+80
+ }
+ -result {}
+}
+test util-13.3 {just over exact - 1 digits} {*}{
+ -body {
+ verdonk_test 1754e31cd072da E+1006 +1_000000000000000000& E+303
+ }
+ -result {}
+}
+test util-13.4 {just over exact - 1 digits} {*}{
+ -body {
+ verdonk_test -1754e31cd072da E+1007 -2_000000000000000000& E+303
+ }
+ -result {}
+}
+test util-13.5 {just over exact - 1 digits} {*}{
+ -body {
+ verdonk_test 1e07b27dd78b14 E-848 +1_00000000000000000& E-255
+ }
+ -result {}
+}
+test util-13.6 {just over exact - 1 digits} {*}{
+ -body {
+ verdonk_test -1e29e9c56687fe E-709 -7_00000000000000000& E-214
+ }
+ -result {}
+}
+test util-13.7 {just over exact - 1 digits} {*}{
+ -body {
+ verdonk_test 1be03d0bf225c7 E-137 +1_00000000000000000& E-41
+ }
+ -result {}
+}
+test util-13.8 {just over exact - 1 digits} {*}{
+ -body {
+ verdonk_test -1a2fe76a3f9475 E-499 -1_00000000000000000& E-150
+ }
+ -result {}
+}
+test util-13.9 {just under exact - 1 digits} {*}{
+ -body {
+ verdonk_test 19a2028368022e E+1019 +8_999999999999999999& E+306
+ }
+ -result {}
+}
+test util-13.10 {just under exact - 1 digits} {*}{
+ -body {
+ verdonk_test -1317e5ef3ab327 E+509 -1_999999999999999999& E+153
+ }
+ -result {}
+}
+test util-13.11 {just under exact - 1 digits} {*}{
+ -body {
+ verdonk_test 1317e5ef3ab327 E+510 +3_99999999999999999& E+153
+ }
+ -result {}
+}
+test util-13.12 {just under exact - 1 digits} {*}{
+ -body {
+ verdonk_test -1317e5ef3ab327 E+511 -7_99999999999999999& E+153
+ }
+ -result {}
+}
+test util-13.13 {just under exact - 1 digits} {*}{
+ -body {
+ verdonk_test 1eb8e84fa0b278 E-1008 +6_999999999999999999& E-304
+ }
+ -result {}
+}
+test util-13.14 {just under exact - 1 digits} {*}{
+ -body {
+ verdonk_test -13339131c46f8b E-1004 -6_999999999999999999& E-303
+ }
+ -result {}
+}
+test util-13.15 {just under exact - 1 digits} {*}{
+ -body {
+ verdonk_test 1c0f92a6276c9d E-162 +2_999999999999999999& E-49
+ }
+ -result {}
+}
+test util-13.16 {just under exact - 1 digits} {*}{
+ -body {
+ verdonk_test -15ce1f143d7ad2 E-443 -5_99999999999999999& E-134
+ }
+ -result {}
+}
+test util-13.17 {just over exact - 2 digits} {*}{
+ -body {
+ verdonk_test 1c0794d9d40e96 E-301 +43_000000000000000000& E-92
+ }
+ -result {}
+}
+test util-13.18 {just over exact - 2 digits} {*}{
+ -body {
+ verdonk_test -1c0794d9d40e96 E-300 -86_000000000000000000& E-92
+ }
+ -result {}
+}
+test util-13.19 {just over exact - 2 digits} {*}{
+ -body {
+ verdonk_test 1cd5bee57763e6 E-241 +51_000000000000000000& E-74
+ }
+ -result {}
+}
+test util-13.20 {just under exact - 2 digits} {*}{
+ -body {
+ verdonk_test 1d1c26db7d0dae E+651 +16_999999999999999999& E+195
+ }
+ -result {}
+}
+test util-13.21 {just under exact - 2 digits} {*}{
+ -body {
+ verdonk_test -13f7ced916872b E-5 -38_999999999999999999& E-3
+ }
+ -result {}
+}
+test util-13.22 {just over exact - 3 digits} {*}{
+ -body {
+ verdonk_test 17d93193f78fc6 E+588 +151_0000000000000000000& E+175
+ }
+ -result {}
+}
+test util-13.23 {just over exact - 3 digits} {*}{
+ -body {
+ verdonk_test -1a82a1631eeb30 E-625 -119_000000000000000000& E-190
+ }
+ -result {}
+}
+test util-13.24 {just under exact - 3 digits} {*}{
+ -body {
+ verdonk_test -16c309024bab4b E+290 -282_999999999999999999& E+85
+ }
+ -result {}
+}
+test util-13.25 {just over exact - 8 digits} {*}{
+ -body {
+ verdonk_test 1dbbac6f83a821 E-800 +27869147_0000000000000000000& E-248
+ }
+ -result {}
+}
+test util-13.26 {just under exact - 9 digits} {*}{
+ -body {
+ verdonk_test -1c569e968e0944 E+430 -491080653_9999999999999999999& E+121
+ }
+ -result {}
+}
+test util-13.27 {just under exact - 9 digits} {*}{
+ -body {
+ verdonk_test 1c569e968e0944 E+429 +245540326_9999999999999999999& E+121
+ }
+ -result {}
+}
+test util-13.28 {just over exact - 10 digits} {*}{
+ -body {
+ verdonk_test -1fc575867314ee E-330 -9078555839_0000000000000000000& E-109
+ }
+ -result {}
+}
+test util-13.29 {just under exact - 10 digits} {*}{
+ -body {
+ verdonk_test -1c569e968e0944 E+428 -1227701634_9999999999999999999& E+120
+ }
+ -result {}
+}
+test util-13.30 {just over exact - 11 digits} {*}{
+ -body {
+ verdonk_test 1fc575867314ee E-329 +18157111678_0000000000000000000& E-109
+ }
+ -result {}
+}
+test util-13.31 {just over exact - 14 digits} {*}{
+ -body {
+ verdonk_test -18bf7e7fa6f02a E-196 -15400733123779_0000000000000000000& E-72
+ }
+ -result {}
+}
+test util-13.32 {just over exact - 17 digits} {*}{
+ -body {
+ verdonk_test -13de005bd620df E+217 -26153245263757307_0000000000000000000& E+49
+ }
+ -result {}
+}
+test util-13.33 {just over exact - 18 digits} {*}{
+ -body {
+ verdonk_test 1f92bacb3cb40c E+718 +272104041512242479_0000000000000000000& E+199
+ }
+ -result {}
+}
+test util-13.34 {just over exact - 18 digits} {*}{
+ -body {
+ verdonk_test -1f92bacb3cb40c E+719 -544208083024484958_0000000000000000000& E+199
+ }
+ -result {}
+}
+test util-13.35 {just over half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test 142dbf25096cf5 E+148 +4_500000000000000000& E+44
+ }
+ -result {}
+}
+test util-13.36 {just over half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test -1afcef51f0fb5f E+263 -2_500000000000000000& E+79
+ }
+ -result {}
+}
+test util-13.37 {just over half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test 102498ea6df0c4 E+145 +4_500000000000000000& E+43
+ }
+ -result {}
+}
+test util-13.38 {just over half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test -1754e31cd072da E+1004 -2_500000000000000000& E+302
+ }
+ -result {}
+}
+test util-13.39 {just over half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test 12deac01e2b4f7 E-557 +2_50000000000000000& E-168
+ }
+ -result {}
+}
+test util-13.40 {just over half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test -1b1df536c13eee E-307 -6_50000000000000000& E-93
+ }
+ -result {}
+}
+test util-13.41 {just over half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test 10711fed5b19a4 E-154 +4_50000000000000000& E-47
+ }
+ -result {}
+}
+test util-13.42 {just over half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test -148d67e8b1e00d E-151 -4_50000000000000000& E-46
+ }
+ -result {}
+}
+test util-13.43 {just under half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test 1c8c574c0c6be7 E+187 +3_49999999999999999& E+56
+ }
+ -result {}
+}
+test util-13.44 {just under half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test -1756183c147514 E+206 -1_49999999999999999& E+62
+ }
+ -result {}
+}
+test util-13.45 {just under half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test 12ab469676c410 E+203 +1_49999999999999999& E+61
+ }
+ -result {}
+}
+test util-13.46 {just under half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test -1539684e774b48 E+246 -1_49999999999999999& E+74
+ }
+ -result {}
+}
+test util-13.47 {just under half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test 12e5f5dfa4fe9d E-286 +9_499999999999999999& E-87
+ }
+ -result {}
+}
+test util-13.48 {just under half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test -1bdc2417bf7787 E-838 -9_499999999999999999& E-253
+ }
+ -result {}
+}
+test util-13.49 {just under half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test 1eb8e84fa0b278 E-1009 +3_499999999999999999& E-304
+ }
+ -result {}
+}
+test util-13.50 {just under half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test -1e3cbc9907fdc8 E-290 -9_499999999999999999& E-88
+ }
+ -result {}
+}
+test util-13.51 {just over half ulp - 2 digits} {*}{
+ -body {
+ verdonk_test 10ad836f269a17 E-324 +30_500000000000000000& E-99
+ }
+ -result {}
+}
+test util-13.52 {just over half ulp - 2 digits} {*}{
+ -body {
+ verdonk_test -1b39ae1909c31b E-687 -26_500000000000000000& E-208
+ }
+ -result {}
+}
+test util-13.53 {just over half ulp - 3 digits} {*}{
+ -body {
+ verdonk_test 1b2ab18615fcc6 E-576 +686_500000000000000000& E-176
+ }
+ -result {}
+}
+test util-13.54 {just over half ulp - 3 digits} {*}{
+ -body {
+ verdonk_test -13e1f90a573064 E-624 -178_500000000000000000& E-190
+ }
+ -result {}
+}
+test util-13.55 {just under half ulp - 3 digits} {*}{
+ -body {
+ verdonk_test 16c309024bab4b E+289 +141_499999999999999999& E+85
+ }
+ -result {}
+}
+test util-13.56 {just under half ulp - 4 digits} {*}{
+ -body {
+ verdonk_test -159bd3ad46e346 E+193 -1695_499999999999999999& E+55
+ }
+ -result {}
+}
+test util-13.57 {just under half ulp - 4 digits} {*}{
+ -body {
+ verdonk_test 1df4170f0fdecc E+124 +3981_499999999999999999& E+34
+ }
+ -result {}
+}
+test util-13.58 {just over half ulp - 6 digits} {*}{
+ -body {
+ verdonk_test 17e1e0f1c7a4ac E+415 +126300_5000000000000000000& E+120
+ }
+ -result {}
+}
+test util-13.59 {just over half ulp - 6 digits} {*}{
+ -body {
+ verdonk_test -1dda592e398dd7 E+418 -126300_5000000000000000000& E+121
+ }
+ -result {}
+}
+test util-13.60 {just under half ulp - 7 digits} {*}{
+ -body {
+ verdonk_test -1e597c0b94b7ae E+453 -4411845_499999999999999999& E+130
+ }
+ -result {}
+}
+test util-13.61 {just under half ulp - 9 digits} {*}{
+ -body {
+ verdonk_test 1c569e968e0944 E+427 +613850817_4999999999999999999& E+120
+ }
+ -result {}
+}
+test util-13.62 {just under half ulp - 9 digits} {*}{
+ -body {
+ verdonk_test -1c569e968e0944 E+428 -122770163_49999999999999999999& E+121
+ }
+ -result {}
+}
+test util-13.63 {just over half ulp - 18 digits} {*}{
+ -body {
+ verdonk_test 17ae0c186d8709 E+719 +408156062268363718_5000000000000000000& E+199
+ }
+ -result {}
+}
+test util-13.64 {just over exact - 1 digits} {*}{
+ -body {
+ verdonk_test 152d02c7e14af7 E+76 +1_0000000000000000& E+23
+ }
+ -result {}
+}
+test util-13.65 {just over exact - 1 digits} {*}{
+ -body {
+ verdonk_test -19d971e4fe8402 E+89 -1_0000000000000000& E+27
+ }
+ -result {}
+}
+test util-13.66 {just over exact - 1 digits} {*}{
+ -body {
+ verdonk_test 19d971e4fe8402 E+90 +2_0000000000000000& E+27
+ }
+ -result {}
+}
+test util-13.67 {just over exact - 1 digits} {*}{
+ -body {
+ verdonk_test -19d971e4fe8402 E+91 -4_0000000000000000& E+27
+ }
+ -result {}
+}
+test util-13.68 {just over exact - 1 digits} {*}{
+ -body {
+ verdonk_test 15798ee2308c3a E-27 +1_0000000000000000& E-8
+ }
+ -result {}
+}
+test util-13.69 {just over exact - 1 digits} {*}{
+ -body {
+ verdonk_test -15798ee2308c3a E-26 -2_0000000000000000& E-8
+ }
+ -result {}
+}
+test util-13.70 {just over exact - 1 digits} {*}{
+ -body {
+ verdonk_test 15798ee2308c3a E-25 +4_0000000000000000& E-8
+ }
+ -result {}
+}
+test util-13.71 {just over exact - 1 digits} {*}{
+ -body {
+ verdonk_test -1ef2d0f5da7dd9 E-84 -1_0000000000000000& E-25
+ }
+ -result {}
+}
+test util-13.72 {just under exact - 1 digits} {*}{
+ -body {
+ verdonk_test 1a784379d99db4 E+78 +4_9999999999999999& E+23
+ }
+ -result {}
+}
+test util-13.73 {just under exact - 1 digits} {*}{
+ -body {
+ verdonk_test -1a784379d99db4 E+80 -1_9999999999999999& E+24
+ }
+ -result {}
+}
+test util-13.74 {just under exact - 1 digits} {*}{
+ -body {
+ verdonk_test 13da329b633647 E+81 +2_9999999999999999& E+24
+ }
+ -result {}
+}
+test util-13.75 {just under exact - 1 digits} {*}{
+ -body {
+ verdonk_test -1cf389cd46047d E+85 -6_9999999999999999& E+25
+ }
+ -result {}
+}
+test util-13.76 {just under exact - 1 digits} {*}{
+ -body {
+ verdonk_test 19999999999999 E-3 +1_99999999999999999& E-1
+ }
+ -result {}
+}
+test util-13.77 {just under exact - 1 digits} {*}{
+ -body {
+ verdonk_test -13333333333333 E-2 -2_99999999999999999& E-1
+ }
+ -result {}
+}
+test util-13.78 {just under exact - 1 digits} {*}{
+ -body {
+ verdonk_test 16849b86a12b9b E-48 +4_99999999999999999& E-15
+ }
+ -result {}
+}
+test util-13.79 {just under exact - 1 digits} {*}{
+ -body {
+ verdonk_test -16849b86a12b9b E-46 -1_99999999999999999& E-14
+ }
+ -result {}
+}
+test util-13.80 {just over exact - 2 digits} {*}{
+ -body {
+ verdonk_test 17ccfc73126788 E-71 +63_00000000000000000& E-23
+ }
+ -result {}
+}
+test util-13.81 {just over exact - 2 digits} {*}{
+ -body {
+ verdonk_test -1dc03b8fd7016a E-68 -63_00000000000000000& E-22
+ }
+ -result {}
+}
+test util-13.82 {just under exact - 2 digits} {*}{
+ -body {
+ verdonk_test 13f7ced916872b E-5 +38_999999999999999999& E-3
+ }
+ -result {}
+}
+test util-13.83 {just over exact - 3 digits} {*}{
+ -body {
+ verdonk_test 1b297cad9f70b6 E+97 +269_000000000000000000& E+27
+ }
+ -result {}
+}
+test util-13.84 {just over exact - 3 digits} {*}{
+ -body {
+ verdonk_test -1b297cad9f70b6 E+98 -538_00000000000000000& E+27
+ }
+ -result {}
+}
+test util-13.85 {just over exact - 3 digits} {*}{
+ -body {
+ verdonk_test 1cdc06b20ef183 E-82 +373_00000000000000000& E-27
+ }
+ -result {}
+}
+test util-13.86 {just over exact - 4 digits} {*}{
+ -body {
+ verdonk_test 1b297cad9f70b6 E+96 +1345_00000000000000000& E+26
+ }
+ -result {}
+}
+# this one is not 4 digits, it is 3, and it is covered above.
+test util-13.87 {just over exact - 4 digits} {*}{
+ -constraints knownBadTest
+ -body {
+ verdonk_test -1b297cad9f70b6 E+97 -2690_00000000000000000& E+26
+ }
+ -result {}
+}
+test util-13.88 {just over exact - 5 digits} {*}{
+ -body {
+ verdonk_test -150a246ecd44f3 E-63 -14257_00000000000000000& E-23
+ }
+ -result {}
+}
+test util-13.89 {just under exact - 6 digits} {*}{
+ -body {
+ verdonk_test -119b96f36ec68b E-19 -209900_999999999999999999& E-11
+ }
+ -result {}
+}
+test util-13.90 {just over exact - 11 digits} {*}{
+ -body {
+ verdonk_test 1c06d366394441 E-35 +50980203373_000000000000000000& E-21
+ }
+ -result {}
+}
+test util-13.91 {just under exact - 12 digits} {*}{
+ -body {
+ verdonk_test -1f58ac4db68c90 E+122 -104166211810_99999999999999999& E+26
+ }
+ -result {}
+}
+test util-13.92 {just over half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test 19d971e4fe8402 E+87 +2_5000000000000000& E+26
+ }
+ -result {}
+}
+test util-13.93 {just over half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test -1dc74be914d16b E+81 -4_500000000000000& E+24
+ }
+ -result {}
+}
+test util-13.94 {just over half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test 14adf4b7320335 E+84 +2_500000000000000& E+25
+ }
+ -result {}
+}
+test util-13.95 {just over half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test -1ae22487c1042b E+85 -6_5000000000000000& E+25
+ }
+ -result {}
+}
+test util-13.96 {just over half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test 187fe49aab41e0 E-54 +8_5000000000000000& E-17
+ }
+ -result {}
+}
+test util-13.97 {just over half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test -1f5c05e4b23fd7 E-61 -8_5000000000000000& E-19
+ }
+ -result {}
+}
+test util-13.98 {just over half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test 1faa7ab552a552 E-42 +4_5000000000000000& E-13
+ }
+ -result {}
+}
+test util-13.99 {just over half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test -1b7cdfd9d7bdbb E-36 -2_5000000000000000& E-11
+ }
+ -result {}
+}
+test util-13.100 {just under half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test 13da329b633647 E+80 +1_4999999999999999& E+24
+ }
+ -result {}
+}
+test util-13.101 {just under half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test -1cf389cd46047d E+84 -3_49999999999999999& E+25
+ }
+ -result {}
+}
+test util-13.102 {just under half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test 1f04ef12cb04cf E+85 +7_4999999999999999& E+25
+ }
+ -result {}
+}
+test util-13.103 {just under half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test -1f04ef12cb04cf E+86 -1_4999999999999999& E+26
+ }
+ -result {}
+}
+test util-13.104 {just under half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test 13333333333333 E-3 +1_49999999999999999& E-1
+ }
+ -result {}
+}
+test util-13.105 {just under half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test -107e1fe91b0b70 E-36 -1_49999999999999999& E-11
+ }
+ -result {}
+}
+test util-13.106 {just under half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test 149da7e361ce4c E-33 +1_49999999999999999& E-10
+ }
+ -result {}
+}
+test util-13.107 {just under half ulp - 1 digits} {*}{
+ -body {
+ verdonk_test -19c511dc3a41df E-30 -1_49999999999999999& E-9
+ }
+ -result {}
+}
+test util-13.108 {just over half ulp - 2 digits} {*}{
+ -body {
+ verdonk_test -1aa83d74267822 E+93 -16_5000000000000000& E+27
+ }
+ -result {}
+}
+test util-13.109 {just over half ulp - 2 digits} {*}{
+ -body {
+ verdonk_test 18f1d5969453de E+89 +96_5000000000000000& E+25
+ }
+ -result {}
+}
+test util-13.110 {just over half ulp - 2 digits} {*}{
+ -body {
+ verdonk_test 11d9bd564dcda6 E-70 +94_50000000000000000& E-23
+ }
+ -result {}
+}
+test util-13.111 {just over half ulp - 2 digits} {*}{
+ -body {
+ verdonk_test -1a58973ecbede6 E-48 -58_50000000000000000& E-16
+ }
+ -result {}
+}
+test util-13.112 {just over half ulp - 3 digits} {*}{
+ -body {
+ verdonk_test 1b297cad9f70b6 E+95 +672_50000000000000000& E+26
+ }
+ -result {}
+}
+test util-13.113 {just over half ulp - 3 digits} {*}{
+ -body {
+ verdonk_test -1b297cad9f70b6 E+96 -134_500000000000000000& E+27
+ }
+ -result {}
+}
+test util-13.114 {just over half ulp - 3 digits} {*}{
+ -body {
+ verdonk_test 1cdc06b20ef183 E-83 +186_50000000000000000& E-27
+ }
+ -result {}
+}
+test util-13.115 {just over half ulp - 3 digits} {*}{
+ -body {
+ verdonk_test -136071dcae4565 E-47 -860_50000000000000000& E-17
+ }
+ -result {}
+}
+test util-13.116 {just over half ulp - 6 digits} {*}{
+ -body {
+ verdonk_test 1cb968d297dde8 E+99 +113788_50000000000000000& E+25
+ }
+ -result {}
+}
+test util-13.117 {just over half ulp - 6 digits} {*}{
+ -body {
+ verdonk_test -11f3e1839eeab1 E+103 -113788_50000000000000000& E+26
+ }
+ -result {}
+}
+test util-13.118 {just under half ulp - 9 digits} {*}{
+ -body {
+ verdonk_test 1e9cec176c96f8 E+117 +317903333_49999999999999999& E+27
+ }
+ -result {}
+}
+test util-13.119 {just over half ulp - 11 digits} {*}{
+ -body {
+ verdonk_test 1c06d366394441 E-36 +25490101686_500000000000000000& E-21
+ }
+ -result {}
+}
+test util-13.120 {just under half ulp - 11 digits} {*}{
+ -body {
+ verdonk_test 1f58ac4db68c90 E+121 +52083105905_49999999999999999& E+26
+ }
+ -result {}
+}
+
+test util-14.1 {funky NaN} {*}{
+ -constraints {ieeeFloatingPoint && controversialNaN}
+ -body {
+ set ieeeValues(-NaN)
+ }
+ -result -NaN
+}
+
+test util-14.2 {funky NaN} {*}{
+ -constraints {ieeeFloatingPoint && controversialNaN}
+ -body {
+ set ieeeValues(-NaN(3456789abcdef))
+ }
+ -result -NaN(3456789abcdef)
+}
+
# cleanup
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End: \ No newline at end of file
generated by cgit v0.12 at 2025-02-02 20:06:27 (GMT)