os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/io.test
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/io.test Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,7232 @@
1.4 +# -*- tcl -*-
1.5 +# Functionality covered: operation of all IO commands, and all procedures
1.6 +# defined in generic/tclIO.c.
1.7 +#
1.8 +# This file contains a collection of tests for one or more of the Tcl
1.9 +# built-in commands. Sourcing this file into Tcl runs the tests and
1.10 +# generates output for errors. No output means no errors were found.
1.11 +#
1.12 +# Copyright (c) 1991-1994 The Regents of the University of California.
1.13 +# Copyright (c) 1994-1997 Sun Microsystems, Inc.
1.14 +# Copyright (c) 1998-1999 by Scriptics Corporation.
1.15 +#
1.16 +# See the file "license.terms" for information on usage and redistribution
1.17 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.18 +#
1.19 +# RCS: @(#) $Id: io.test,v 1.40.2.12 2007/02/12 19:25:42 andreas_kupries Exp $
1.20 +
1.21 +if {[catch {package require tcltest 2}]} {
1.22 + puts stderr "Skipping tests in [info script]. tcltest 2 required."
1.23 + return
1.24 +}
1.25 +namespace eval ::tcl::test::io {
1.26 +
1.27 + namespace import ::tcltest::cleanupTests
1.28 + namespace import ::tcltest::interpreter
1.29 + namespace import ::tcltest::makeFile
1.30 + namespace import ::tcltest::removeFile
1.31 + namespace import ::tcltest::test
1.32 + namespace import ::tcltest::testConstraint
1.33 + namespace import ::tcltest::viewFile
1.34 +
1.35 +testConstraint testchannel [llength [info commands testchannel]]
1.36 +testConstraint exec [llength [info commands exec]]
1.37 +testConstraint openpipe 1
1.38 +testConstraint fileevent [llength [info commands fileevent]]
1.39 +testConstraint fcopy [llength [info commands fcopy]]
1.40 +
1.41 +# You need a *very* special environment to do some tests. In
1.42 +# particular, many file systems do not support large-files...
1.43 +testConstraint largefileSupport 0
1.44 +
1.45 +# set up a long data file for some of the following tests
1.46 +
1.47 +set path(longfile) [makeFile {} longfile]
1.48 +set f [open $path(longfile) w]
1.49 +fconfigure $f -eofchar {} -translation lf
1.50 +for { set i 0 } { $i < 100 } { incr i} {
1.51 + puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef
1.52 +\#123456789abcdef01
1.53 +\#"
1.54 + }
1.55 +close $f
1.56 +
1.57 +set path(cat) [makeFile {
1.58 + set f stdin
1.59 + if {$argv != ""} {
1.60 + set f [open [lindex $argv 0]]
1.61 + }
1.62 + fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar \x1a
1.63 + fconfigure stdout -encoding binary -translation lf -buffering none
1.64 + fileevent $f readable "foo $f"
1.65 + proc foo {f} {
1.66 + set x [read $f]
1.67 + catch {puts -nonewline $x}
1.68 + if {[eof $f]} {
1.69 + close $f
1.70 + exit 0
1.71 + }
1.72 + }
1.73 + vwait forever
1.74 +} cat]
1.75 +
1.76 +set thisScript [file join [pwd] [info script]]
1.77 +
1.78 +proc contents {file} {
1.79 + set f [open $file]
1.80 + fconfigure $f -translation binary
1.81 + set a [read $f]
1.82 + close $f
1.83 + return $a
1.84 +}
1.85 +
1.86 +test io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} {
1.87 + # no test, need to cause an async error.
1.88 +} {}
1.89 +
1.90 +set path(test1) [makeFile {} test1]
1.91 +
1.92 +test io-1.6 {Tcl_WriteChars: WriteBytes} {
1.93 + set f [open $path(test1) w]
1.94 + fconfigure $f -encoding binary
1.95 + puts -nonewline $f "a\u4e4d\0"
1.96 + close $f
1.97 + contents $path(test1)
1.98 +} "a\x4d\x00"
1.99 +test io-1.7 {Tcl_WriteChars: WriteChars} {
1.100 + set f [open $path(test1) w]
1.101 + fconfigure $f -encoding shiftjis
1.102 + puts -nonewline $f "a\u4e4d\0"
1.103 + close $f
1.104 + contents $path(test1)
1.105 +} "a\x93\xe1\x00"
1.106 +
1.107 +set path(test2) [makeFile {} test2]
1.108 +
1.109 +test io-1.8 {Tcl_WriteChars: WriteChars} {
1.110 + # This test written for SF bug #506297.
1.111 + #
1.112 + # Executing this test without the fix for the referenced bug
1.113 + # applied to tcl will cause tcl, more specifically WriteChars, to
1.114 + # go into an infinite loop.
1.115 +
1.116 + set f [open $path(test2) w]
1.117 + fconfigure $f -encoding iso2022-jp
1.118 + puts -nonewline $f [format %s%c [string repeat " " 4] 12399]
1.119 + close $f
1.120 + contents $path(test2)
1.121 +} " \x1b\$B\$O\x1b(B"
1.122 +
1.123 +test io-1.9 {Tcl_WriteChars: WriteChars} {
1.124 + # When closing a channel with an encoding that appends
1.125 + # escape bytes, check for the case where the escape
1.126 + # bytes overflow the current IO buffer. The bytes
1.127 + # should be moved into a new buffer.
1.128 +
1.129 + set data "1234567890 [format %c 12399]"
1.130 +
1.131 + set sizes [list]
1.132 +
1.133 + # With default buffer size
1.134 + set f [open $path(test2) w]
1.135 + fconfigure $f -encoding iso2022-jp
1.136 + puts -nonewline $f $data
1.137 + close $f
1.138 + lappend sizes [file size $path(test2)]
1.139 +
1.140 + # With buffer size equal to the length
1.141 + # of the data, the escape bytes would
1.142 + # go into the next buffer.
1.143 +
1.144 + set f [open $path(test2) w]
1.145 + fconfigure $f -encoding iso2022-jp -buffersize 16
1.146 + puts -nonewline $f $data
1.147 + close $f
1.148 + lappend sizes [file size $path(test2)]
1.149 +
1.150 + # With buffer size that is large enough
1.151 + # to hold 1 byte of escaped data, but
1.152 + # not all 3. This should not write
1.153 + # the escape bytes to the first buffer
1.154 + # and then again to the second buffer.
1.155 +
1.156 + set f [open $path(test2) w]
1.157 + fconfigure $f -encoding iso2022-jp -buffersize 17
1.158 + puts -nonewline $f $data
1.159 + close $f
1.160 + lappend sizes [file size $path(test2)]
1.161 +
1.162 + # With buffer size that can hold 2 out of
1.163 + # 3 bytes of escaped data.
1.164 +
1.165 + set f [open $path(test2) w]
1.166 + fconfigure $f -encoding iso2022-jp -buffersize 18
1.167 + puts -nonewline $f $data
1.168 + close $f
1.169 + lappend sizes [file size $path(test2)]
1.170 +
1.171 + # With buffer size that can hold all the
1.172 + # data and escape bytes.
1.173 +
1.174 + set f [open $path(test2) w]
1.175 + fconfigure $f -encoding iso2022-jp -buffersize 19
1.176 + puts -nonewline $f $data
1.177 + close $f
1.178 + lappend sizes [file size $path(test2)]
1.179 +
1.180 + set sizes
1.181 +} {19 19 19 19 19}
1.182 +
1.183 +test io-2.1 {WriteBytes} {
1.184 + # loop until all bytes are written
1.185 +
1.186 + set f [open $path(test1) w]
1.187 + fconfigure $f -encoding binary -buffersize 16 -translation crlf
1.188 + puts $f "abcdefghijklmnopqrstuvwxyz"
1.189 + close $f
1.190 + contents $path(test1)
1.191 +} "abcdefghijklmnopqrstuvwxyz\r\n"
1.192 +test io-2.2 {WriteBytes: savedLF > 0} {
1.193 + # After flushing buffer, there was a \n left over from the last
1.194 + # \n -> \r\n expansion. It gets stuck at beginning of this buffer.
1.195 +
1.196 + set f [open $path(test1) w]
1.197 + fconfigure $f -encoding binary -buffersize 16 -translation crlf
1.198 + puts -nonewline $f "123456789012345\n12"
1.199 + set x [list [contents $path(test1)]]
1.200 + close $f
1.201 + lappend x [contents $path(test1)]
1.202 +} [list "123456789012345\r" "123456789012345\r\n12"]
1.203 +test io-2.3 {WriteBytes: flush on line} {
1.204 + # Tcl "line" buffering has weird behavior: if current buffer contains
1.205 + # a \n, entire buffer gets flushed. Logical behavior would be to flush
1.206 + # only up to the \n.
1.207 +
1.208 + set f [open $path(test1) w]
1.209 + fconfigure $f -encoding binary -buffering line -translation crlf
1.210 + puts -nonewline $f "\n12"
1.211 + set x [contents $path(test1)]
1.212 + close $f
1.213 + set x
1.214 +} "\r\n12"
1.215 +test io-2.4 {WriteBytes: reset sawLF after each buffer} {
1.216 + set f [open $path(test1) w]
1.217 + fconfigure $f -encoding binary -buffering line -translation lf \
1.218 + -buffersize 16
1.219 + puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz"
1.220 + set x [list [contents $path(test1)]]
1.221 + close $f
1.222 + lappend x [contents $path(test1)]
1.223 +} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]
1.224 +
1.225 +test io-3.1 {WriteChars: compatibility with WriteBytes} {
1.226 + # loop until all bytes are written
1.227 +
1.228 + set f [open $path(test1) w]
1.229 + fconfigure $f -encoding ascii -buffersize 16 -translation crlf
1.230 + puts $f "abcdefghijklmnopqrstuvwxyz"
1.231 + close $f
1.232 + contents $path(test1)
1.233 +} "abcdefghijklmnopqrstuvwxyz\r\n"
1.234 +test io-3.2 {WriteChars: compatibility with WriteBytes: savedLF > 0} {
1.235 + # After flushing buffer, there was a \n left over from the last
1.236 + # \n -> \r\n expansion. It gets stuck at beginning of this buffer.
1.237 +
1.238 + set f [open $path(test1) w]
1.239 + fconfigure $f -encoding ascii -buffersize 16 -translation crlf
1.240 + puts -nonewline $f "123456789012345\n12"
1.241 + set x [list [contents $path(test1)]]
1.242 + close $f
1.243 + lappend x [contents $path(test1)]
1.244 +} [list "123456789012345\r" "123456789012345\r\n12"]
1.245 +test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} {
1.246 + # Tcl "line" buffering has weird behavior: if current buffer contains
1.247 + # a \n, entire buffer gets flushed. Logical behavior would be to flush
1.248 + # only up to the \n.
1.249 +
1.250 + set f [open $path(test1) w]
1.251 + fconfigure $f -encoding ascii -buffering line -translation crlf
1.252 + puts -nonewline $f "\n12"
1.253 + set x [contents $path(test1)]
1.254 + close $f
1.255 + set x
1.256 +} "\r\n12"
1.257 +test io-3.4 {WriteChars: loop over stage buffer} {
1.258 + # stage buffer maps to more than can be queued at once.
1.259 +
1.260 + set f [open $path(test1) w]
1.261 + fconfigure $f -encoding jis0208 -buffersize 16
1.262 + puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
1.263 + set x [list [contents $path(test1)]]
1.264 + close $f
1.265 + lappend x [contents $path(test1)]
1.266 +} [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
1.267 +test io-3.5 {WriteChars: saved != 0} {
1.268 + # Bytes produced by UtfToExternal from end of last channel buffer
1.269 + # had to be moved to beginning of next channel buffer to preserve
1.270 + # requested buffersize.
1.271 +
1.272 + set f [open $path(test1) w]
1.273 + fconfigure $f -encoding jis0208 -buffersize 17
1.274 + puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
1.275 + set x [list [contents $path(test1)]]
1.276 + close $f
1.277 + lappend x [contents $path(test1)]
1.278 +} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
1.279 +test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} {
1.280 + # One incomplete UTF-8 character at end of staging buffer. Backup
1.281 + # in src to the beginning of that UTF-8 character and try again.
1.282 + #
1.283 + # Translate the first 16 bytes, produce 14 bytes of output, 2 left over
1.284 + # (first two bytes of \uff21 in UTF-8). Given those two bytes try
1.285 + # translating them again, find that no bytes are read produced, and break
1.286 + # to outer loop where those two bytes will have the remaining 4 bytes
1.287 + # (the last byte of \uff21 plus the all of \uff22) appended.
1.288 +
1.289 + set f [open $path(test1) w]
1.290 + fconfigure $f -encoding shiftjis -buffersize 16
1.291 + puts -nonewline $f "12345678901234\uff21\uff22"
1.292 + set x [list [contents $path(test1)]]
1.293 + close $f
1.294 + lappend x [contents $path(test1)]
1.295 +} [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"]
1.296 +test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} {
1.297 + # When translating UTF-8 to external, the produced bytes went past end
1.298 + # of the channel buffer. This is done purpose -- we then truncate the
1.299 + # bytes at the end of the partial character to preserve the requested
1.300 + # blocksize on flush. The truncated bytes are moved to the beginning
1.301 + # of the next channel buffer.
1.302 +
1.303 + set f [open $path(test1) w]
1.304 + fconfigure $f -encoding jis0208 -buffersize 17
1.305 + puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
1.306 + set x [list [contents $path(test1)]]
1.307 + close $f
1.308 + lappend x [contents $path(test1)]
1.309 +} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
1.310 +test io-3.8 {WriteChars: reset sawLF after each buffer} {
1.311 + set f [open $path(test1) w]
1.312 + fconfigure $f -encoding ascii -buffering line -translation lf \
1.313 + -buffersize 16
1.314 + puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz"
1.315 + set x [list [contents $path(test1)]]
1.316 + close $f
1.317 + lappend x [contents $path(test1)]
1.318 +} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]
1.319 +
1.320 +test io-4.1 {TranslateOutputEOL: lf} {
1.321 + # search for \n
1.322 +
1.323 + set f [open $path(test1) w]
1.324 + fconfigure $f -buffering line -translation lf
1.325 + puts $f "abcde"
1.326 + set x [list [contents $path(test1)]]
1.327 + close $f
1.328 + lappend x [contents $path(test1)]
1.329 +} [list "abcde\n" "abcde\n"]
1.330 +test io-4.2 {TranslateOutputEOL: cr} {
1.331 + # search for \n, replace with \r
1.332 +
1.333 + set f [open $path(test1) w]
1.334 + fconfigure $f -buffering line -translation cr
1.335 + puts $f "abcde"
1.336 + set x [list [contents $path(test1)]]
1.337 + close $f
1.338 + lappend x [contents $path(test1)]
1.339 +} [list "abcde\r" "abcde\r"]
1.340 +test io-4.3 {TranslateOutputEOL: crlf} {
1.341 + # simple case: search for \n, replace with \r
1.342 +
1.343 + set f [open $path(test1) w]
1.344 + fconfigure $f -buffering line -translation crlf
1.345 + puts $f "abcde"
1.346 + set x [list [contents $path(test1)]]
1.347 + close $f
1.348 + lappend x [contents $path(test1)]
1.349 +} [list "abcde\r\n" "abcde\r\n"]
1.350 +test io-4.4 {TranslateOutputEOL: crlf} {
1.351 + # keep storing more bytes in output buffer until output buffer is full.
1.352 + # We have 13 bytes initially that would turn into 18 bytes. Fill
1.353 + # dest buffer while (dstEnd < dstMax).
1.354 +
1.355 + set f [open $path(test1) w]
1.356 + fconfigure $f -translation crlf -buffersize 16
1.357 + puts -nonewline $f "1234567\n\n\n\n\nA"
1.358 + set x [list [contents $path(test1)]]
1.359 + close $f
1.360 + lappend x [contents $path(test1)]
1.361 +} [list "1234567\r\n\r\n\r\n\r\n\r" "1234567\r\n\r\n\r\n\r\n\r\nA"]
1.362 +test io-4.5 {TranslateOutputEOL: crlf} {
1.363 + # Check for overflow of the destination buffer
1.364 +
1.365 + set f [open $path(test1) w]
1.366 + fconfigure $f -translation crlf -buffersize 12
1.367 + puts -nonewline $f "12345678901\n456789012345678901234"
1.368 + close $f
1.369 + set x [contents $path(test1)]
1.370 +} "12345678901\r\n456789012345678901234"
1.371 +
1.372 +test io-5.1 {CheckFlush: not full} {
1.373 + set f [open $path(test1) w]
1.374 + fconfigure $f
1.375 + puts -nonewline $f "12345678901234567890"
1.376 + set x [list [contents $path(test1)]]
1.377 + close $f
1.378 + lappend x [contents $path(test1)]
1.379 +} [list "" "12345678901234567890"]
1.380 +test io-5.2 {CheckFlush: full} {
1.381 + set f [open $path(test1) w]
1.382 + fconfigure $f -buffersize 16
1.383 + puts -nonewline $f "12345678901234567890"
1.384 + set x [list [contents $path(test1)]]
1.385 + close $f
1.386 + lappend x [contents $path(test1)]
1.387 +} [list "1234567890123456" "12345678901234567890"]
1.388 +test io-5.3 {CheckFlush: not line} {
1.389 + set f [open $path(test1) w]
1.390 + fconfigure $f -buffering line
1.391 + puts -nonewline $f "12345678901234567890"
1.392 + set x [list [contents $path(test1)]]
1.393 + close $f
1.394 + lappend x [contents $path(test1)]
1.395 +} [list "" "12345678901234567890"]
1.396 +test io-5.4 {CheckFlush: line} {
1.397 + set f [open $path(test1) w]
1.398 + fconfigure $f -buffering line -translation lf -encoding ascii
1.399 + puts -nonewline $f "1234567890\n1234567890"
1.400 + set x [list [contents $path(test1)]]
1.401 + close $f
1.402 + lappend x [contents $path(test1)]
1.403 +} [list "1234567890\n1234567890" "1234567890\n1234567890"]
1.404 +test io-5.5 {CheckFlush: none} {
1.405 + set f [open $path(test1) w]
1.406 + fconfigure $f -buffering none
1.407 + puts -nonewline $f "1234567890"
1.408 + set x [list [contents $path(test1)]]
1.409 + close $f
1.410 + lappend x [contents $path(test1)]
1.411 +} [list "1234567890" "1234567890"]
1.412 +
1.413 +test io-6.1 {Tcl_GetsObj: working} {
1.414 + set f [open $path(test1) w]
1.415 + puts $f "foo\nboo"
1.416 + close $f
1.417 + set f [open $path(test1)]
1.418 + set x [gets $f]
1.419 + close $f
1.420 + set x
1.421 +} {foo}
1.422 +test io-6.2 {Tcl_GetsObj: CheckChannelErrors() != 0} {
1.423 + # no test, need to cause an async error.
1.424 +} {}
1.425 +test io-6.3 {Tcl_GetsObj: how many have we used?} {
1.426 + # if (bufPtr != NULL) {oldRemoved = bufPtr->nextRemoved}
1.427 +
1.428 + set f [open $path(test1) w]
1.429 + fconfigure $f -translation crlf
1.430 + puts $f "abc\ndefg"
1.431 + close $f
1.432 + set f [open $path(test1)]
1.433 + set x [list [tell $f] [gets $f line] [tell $f] [gets $f line] $line]
1.434 + close $f
1.435 + set x
1.436 +} {0 3 5 4 defg}
1.437 +test io-6.4 {Tcl_GetsObj: encoding == NULL} {
1.438 + set f [open $path(test1) w]
1.439 + fconfigure $f -translation binary
1.440 + puts $f "\x81\u1234\0"
1.441 + close $f
1.442 + set f [open $path(test1)]
1.443 + fconfigure $f -translation binary
1.444 + set x [list [gets $f line] $line]
1.445 + close $f
1.446 + set x
1.447 +} [list 3 "\x81\x34\x00"]
1.448 +test io-6.5 {Tcl_GetsObj: encoding != NULL} {
1.449 + set f [open $path(test1) w]
1.450 + fconfigure $f -translation binary
1.451 + puts $f "\x88\xea\x92\x9a"
1.452 + close $f
1.453 + set f [open $path(test1)]
1.454 + fconfigure $f -encoding shiftjis
1.455 + set x [list [gets $f line] $line]
1.456 + close $f
1.457 + set x
1.458 +} [list 2 "\u4e00\u4e01"]
1.459 +set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
1.460 +append a $a
1.461 +append a $a
1.462 +test io-6.6 {Tcl_GetsObj: loop test} {
1.463 + # if (dst >= dstEnd)
1.464 +
1.465 + set f [open $path(test1) w]
1.466 + puts $f $a
1.467 + puts $f hi
1.468 + close $f
1.469 + set f [open $path(test1)]
1.470 + set x [list [gets $f line] $line]
1.471 + close $f
1.472 + set x
1.473 +} [list 256 $a]
1.474 +test io-6.7 {Tcl_GetsObj: error in input} {stdio openpipe} {
1.475 + # if (FilterInputBytes(chanPtr, &gs) != 0)
1.476 +
1.477 + set f [open "|[list [interpreter] $path(cat)]" w+]
1.478 + puts -nonewline $f "hi\nwould"
1.479 + flush $f
1.480 + gets $f
1.481 + fconfigure $f -blocking 0
1.482 + set x [gets $f line]
1.483 + close $f
1.484 + set x
1.485 +} {-1}
1.486 +test io-6.8 {Tcl_GetsObj: remember if EOF is seen} {
1.487 + set f [open $path(test1) w]
1.488 + puts $f "abcdef\x1aghijk\nwombat"
1.489 + close $f
1.490 + set f [open $path(test1)]
1.491 + fconfigure $f -eofchar \x1a
1.492 + set x [list [gets $f line] $line [gets $f line] $line]
1.493 + close $f
1.494 + set x
1.495 +} {6 abcdef -1 {}}
1.496 +test io-6.9 {Tcl_GetsObj: remember if EOF is seen} {
1.497 + set f [open $path(test1) w]
1.498 + puts $f "abcdefghijk\nwom\u001abat"
1.499 + close $f
1.500 + set f [open $path(test1)]
1.501 + fconfigure $f -eofchar \x1a
1.502 + set x [list [gets $f line] $line [gets $f line] $line]
1.503 + close $f
1.504 + set x
1.505 +} {11 abcdefghijk 3 wom}
1.506 +
1.507 +# Comprehensive tests
1.508 +
1.509 +test io-6.10 {Tcl_GetsObj: lf mode: no chars} {
1.510 + set f [open $path(test1) w]
1.511 + close $f
1.512 + set f [open $path(test1)]
1.513 + fconfigure $f -translation lf
1.514 + set x [list [gets $f line] $line]
1.515 + close $f
1.516 + set x
1.517 +} {-1 {}}
1.518 +test io-6.11 {Tcl_GetsObj: lf mode: lone \n} {
1.519 + set f [open $path(test1) w]
1.520 + fconfigure $f -translation lf
1.521 + puts -nonewline $f "\n"
1.522 + close $f
1.523 + set f [open $path(test1)]
1.524 + fconfigure $f -translation lf
1.525 + set x [list [gets $f line] $line [gets $f line] $line]
1.526 + close $f
1.527 + set x
1.528 +} {0 {} -1 {}}
1.529 +test io-6.12 {Tcl_GetsObj: lf mode: lone \r} {
1.530 + set f [open $path(test1) w]
1.531 + fconfigure $f -translation lf
1.532 + puts -nonewline $f "\r"
1.533 + close $f
1.534 + set f [open $path(test1)]
1.535 + fconfigure $f -translation lf
1.536 + set x [list [gets $f line] $line [gets $f line] $line]
1.537 + close $f
1.538 + set x
1.539 +} [list 1 "\r" -1 ""]
1.540 +test io-6.13 {Tcl_GetsObj: lf mode: 1 char} {
1.541 + set f [open $path(test1) w]
1.542 + fconfigure $f -translation lf
1.543 + puts -nonewline $f a
1.544 + close $f
1.545 + set f [open $path(test1)]
1.546 + fconfigure $f -translation lf
1.547 + set x [list [gets $f line] $line [gets $f line] $line]
1.548 + close $f
1.549 + set x
1.550 +} {1 a -1 {}}
1.551 +test io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} {
1.552 + set f [open $path(test1) w]
1.553 + fconfigure $f -translation lf
1.554 + puts -nonewline $f "a\n"
1.555 + close $f
1.556 + set f [open $path(test1)]
1.557 + fconfigure $f -translation lf
1.558 + set x [list [gets $f line] $line [gets $f line] $line]
1.559 + close $f
1.560 + set x
1.561 +} {1 a -1 {}}
1.562 +test io-6.15 {Tcl_GetsObj: lf mode: several chars} {
1.563 + set f [open $path(test1) w]
1.564 + fconfigure $f -translation lf
1.565 + puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
1.566 + close $f
1.567 + set f [open $path(test1)]
1.568 + fconfigure $f -translation lf
1.569 + set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line]
1.570 + close $f
1.571 + set x
1.572 +} [list 4 "abcd" 10 "efgh\rijkl\r" 4 "mnop" -1 ""]
1.573 +test io-6.16 {Tcl_GetsObj: cr mode: no chars} {
1.574 + set f [open $path(test1) w]
1.575 + close $f
1.576 + set f [open $path(test1)]
1.577 + fconfigure $f -translation cr
1.578 + set x [list [gets $f line] $line]
1.579 + close $f
1.580 + set x
1.581 +} {-1 {}}
1.582 +test io-6.17 {Tcl_GetsObj: cr mode: lone \n} {
1.583 + set f [open $path(test1) w]
1.584 + fconfigure $f -translation lf
1.585 + puts -nonewline $f "\n"
1.586 + close $f
1.587 + set f [open $path(test1)]
1.588 + fconfigure $f -translation cr
1.589 + set x [list [gets $f line] $line [gets $f line] $line]
1.590 + close $f
1.591 + set x
1.592 +} [list 1 "\n" -1 ""]
1.593 +test io-6.18 {Tcl_GetsObj: cr mode: lone \r} {
1.594 + set f [open $path(test1) w]
1.595 + fconfigure $f -translation lf
1.596 + puts -nonewline $f "\r"
1.597 + close $f
1.598 + set f [open $path(test1)]
1.599 + fconfigure $f -translation cr
1.600 + set x [list [gets $f line] $line [gets $f line] $line]
1.601 + close $f
1.602 + set x
1.603 +} {0 {} -1 {}}
1.604 +test io-6.19 {Tcl_GetsObj: cr mode: 1 char} {
1.605 + set f [open $path(test1) w]
1.606 + fconfigure $f -translation lf
1.607 + puts -nonewline $f a
1.608 + close $f
1.609 + set f [open $path(test1)]
1.610 + fconfigure $f -translation cr
1.611 + set x [list [gets $f line] $line [gets $f line] $line]
1.612 + close $f
1.613 + set x
1.614 +} {1 a -1 {}}
1.615 +test io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} {
1.616 + set f [open $path(test1) w]
1.617 + fconfigure $f -translation lf
1.618 + puts -nonewline $f "a\r"
1.619 + close $f
1.620 + set f [open $path(test1)]
1.621 + fconfigure $f -translation cr
1.622 + set x [list [gets $f line] $line [gets $f line] $line]
1.623 + close $f
1.624 + set x
1.625 +} {1 a -1 {}}
1.626 +test io-6.21 {Tcl_GetsObj: cr mode: several chars} {
1.627 + set f [open $path(test1) w]
1.628 + fconfigure $f -translation lf
1.629 + puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
1.630 + close $f
1.631 + set f [open $path(test1)]
1.632 + fconfigure $f -translation cr
1.633 + set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line]
1.634 + close $f
1.635 + set x
1.636 +} [list 9 "abcd\nefgh" 4 "ijkl" 5 "\nmnop" -1 ""]
1.637 +test io-6.22 {Tcl_GetsObj: crlf mode: no chars} {
1.638 + set f [open $path(test1) w]
1.639 + close $f
1.640 + set f [open $path(test1)]
1.641 + fconfigure $f -translation crlf
1.642 + set x [list [gets $f line] $line]
1.643 + close $f
1.644 + set x
1.645 +} {-1 {}}
1.646 +test io-6.23 {Tcl_GetsObj: crlf mode: lone \n} {
1.647 + set f [open $path(test1) w]
1.648 + fconfigure $f -translation lf
1.649 + puts -nonewline $f "\n"
1.650 + close $f
1.651 + set f [open $path(test1)]
1.652 + fconfigure $f -translation crlf
1.653 + set x [list [gets $f line] $line [gets $f line] $line]
1.654 + close $f
1.655 + set x
1.656 +} [list 1 "\n" -1 ""]
1.657 +test io-6.24 {Tcl_GetsObj: crlf mode: lone \r} {
1.658 + set f [open $path(test1) w]
1.659 + fconfigure $f -translation lf
1.660 + puts -nonewline $f "\r"
1.661 + close $f
1.662 + set f [open $path(test1)]
1.663 + fconfigure $f -translation crlf
1.664 + set x [list [gets $f line] $line [gets $f line] $line]
1.665 + close $f
1.666 + set x
1.667 +} [list 1 "\r" -1 ""]
1.668 +test io-6.25 {Tcl_GetsObj: crlf mode: \r\r} {
1.669 + set f [open $path(test1) w]
1.670 + fconfigure $f -translation lf
1.671 + puts -nonewline $f "\r\r"
1.672 + close $f
1.673 + set f [open $path(test1)]
1.674 + fconfigure $f -translation crlf
1.675 + set x [list [gets $f line] $line [gets $f line] $line]
1.676 + close $f
1.677 + set x
1.678 +} [list 2 "\r\r" -1 ""]
1.679 +test io-6.26 {Tcl_GetsObj: crlf mode: \r\n} {
1.680 + set f [open $path(test1) w]
1.681 + fconfigure $f -translation lf
1.682 + puts -nonewline $f "\r\n"
1.683 + close $f
1.684 + set f [open $path(test1)]
1.685 + fconfigure $f -translation crlf
1.686 + set x [list [gets $f line] $line [gets $f line] $line]
1.687 + close $f
1.688 + set x
1.689 +} [list 0 "" -1 ""]
1.690 +test io-6.27 {Tcl_GetsObj: crlf mode: 1 char} {
1.691 + set f [open $path(test1) w]
1.692 + fconfigure $f -translation lf
1.693 + puts -nonewline $f a
1.694 + close $f
1.695 + set f [open $path(test1)]
1.696 + fconfigure $f -translation crlf
1.697 + set x [list [gets $f line] $line [gets $f line] $line]
1.698 + close $f
1.699 + set x
1.700 +} {1 a -1 {}}
1.701 +test io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} {
1.702 + set f [open $path(test1) w]
1.703 + fconfigure $f -translation lf
1.704 + puts -nonewline $f "a\r\n"
1.705 + close $f
1.706 + set f [open $path(test1)]
1.707 + fconfigure $f -translation crlf
1.708 + set x [list [gets $f line] $line [gets $f line] $line]
1.709 + close $f
1.710 + set x
1.711 +} {1 a -1 {}}
1.712 +test io-6.29 {Tcl_GetsObj: crlf mode: several chars} {
1.713 + set f [open $path(test1) w]
1.714 + fconfigure $f -translation lf
1.715 + puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
1.716 + close $f
1.717 + set f [open $path(test1)]
1.718 + fconfigure $f -translation crlf
1.719 + set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
1.720 + close $f
1.721 + set x
1.722 +} [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""]
1.723 +test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} {
1.724 + # if (eol >= dstEnd)
1.725 +
1.726 + set f [open $path(test1) w]
1.727 + fconfigure $f -translation lf
1.728 + puts -nonewline $f "123456789012345\r\nabcdefghijklmnoprstuvwxyz"
1.729 + close $f
1.730 + set f [open $path(test1)]
1.731 + fconfigure $f -translation crlf -buffersize 16
1.732 + set x [list [gets $f line] $line [testchannel inputbuffered $f]]
1.733 + close $f
1.734 + set x
1.735 +} [list 15 "123456789012345" 15]
1.736 +test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel openpipe fileevent} {
1.737 + # (FilterInputBytes() != 0)
1.738 +
1.739 + set f [open "|[list [interpreter] $path(cat)]" w+]
1.740 + fconfigure $f -translation {crlf lf} -buffering none
1.741 + puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r"
1.742 + fconfigure $f -buffersize 16
1.743 + set x [gets $f]
1.744 + fconfigure $f -blocking 0
1.745 + lappend x [gets $f line] $line [fblocked $f] [testchannel inputbuffered $f]
1.746 + close $f
1.747 + set x
1.748 +} [list "bbbbbbbbbbbbbb" -1 "" 1 16]
1.749 +test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} {
1.750 + # not (FilterInputBytes() != 0)
1.751 +
1.752 + set f [open $path(test1) w]
1.753 + fconfigure $f -translation lf
1.754 + puts -nonewline $f "123456789012345\r\n123"
1.755 + close $f
1.756 + set f [open $path(test1)]
1.757 + fconfigure $f -translation crlf -buffersize 16
1.758 + set x [list [gets $f line] $line [tell $f] [testchannel inputbuffered $f]]
1.759 + close $f
1.760 + set x
1.761 +} [list 15 "123456789012345" 17 3]
1.762 +test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} {
1.763 + # eol still equals dstEnd
1.764 +
1.765 + set f [open $path(test1) w]
1.766 + fconfigure $f -translation lf
1.767 + puts -nonewline $f "123456789012345\r"
1.768 + close $f
1.769 + set f [open $path(test1)]
1.770 + fconfigure $f -translation crlf -buffersize 16
1.771 + set x [list [gets $f line] $line [eof $f]]
1.772 + close $f
1.773 + set x
1.774 +} [list 16 "123456789012345\r" 1]
1.775 +test io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} {
1.776 + # not (*eol == '\n')
1.777 +
1.778 + set f [open $path(test1) w]
1.779 + fconfigure $f -translation lf
1.780 + puts -nonewline $f "123456789012345\rabcd\r\nefg"
1.781 + close $f
1.782 + set f [open $path(test1)]
1.783 + fconfigure $f -translation crlf -buffersize 16
1.784 + set x [list [gets $f line] $line [tell $f]]
1.785 + close $f
1.786 + set x
1.787 +} [list 20 "123456789012345\rabcd" 22]
1.788 +test io-6.35 {Tcl_GetsObj: auto mode: no chars} {
1.789 + set f [open $path(test1) w]
1.790 + close $f
1.791 + set f [open $path(test1)]
1.792 + fconfigure $f -translation auto
1.793 + set x [list [gets $f line] $line]
1.794 + close $f
1.795 + set x
1.796 +} {-1 {}}
1.797 +test io-6.36 {Tcl_GetsObj: auto mode: lone \n} {
1.798 + set f [open $path(test1) w]
1.799 + fconfigure $f -translation lf
1.800 + puts -nonewline $f "\n"
1.801 + close $f
1.802 + set f [open $path(test1)]
1.803 + fconfigure $f -translation auto
1.804 + set x [list [gets $f line] $line [gets $f line] $line]
1.805 + close $f
1.806 + set x
1.807 +} [list 0 "" -1 ""]
1.808 +test io-6.37 {Tcl_GetsObj: auto mode: lone \r} {
1.809 + set f [open $path(test1) w]
1.810 + fconfigure $f -translation lf
1.811 + puts -nonewline $f "\r"
1.812 + close $f
1.813 + set f [open $path(test1)]
1.814 + fconfigure $f -translation auto
1.815 + set x [list [gets $f line] $line [gets $f line] $line]
1.816 + close $f
1.817 + set x
1.818 +} [list 0 "" -1 ""]
1.819 +test io-6.38 {Tcl_GetsObj: auto mode: \r\r} {
1.820 + set f [open $path(test1) w]
1.821 + fconfigure $f -translation lf
1.822 + puts -nonewline $f "\r\r"
1.823 + close $f
1.824 + set f [open $path(test1)]
1.825 + fconfigure $f -translation auto
1.826 + set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
1.827 + close $f
1.828 + set x
1.829 +} [list 0 "" 0 "" -1 ""]
1.830 +test io-6.39 {Tcl_GetsObj: auto mode: \r\n} {
1.831 + set f [open $path(test1) w]
1.832 + fconfigure $f -translation lf
1.833 + puts -nonewline $f "\r\n"
1.834 + close $f
1.835 + set f [open $path(test1)]
1.836 + fconfigure $f -translation auto
1.837 + set x [list [gets $f line] $line [gets $f line] $line]
1.838 + close $f
1.839 + set x
1.840 +} [list 0 "" -1 ""]
1.841 +test io-6.40 {Tcl_GetsObj: auto mode: 1 char} {
1.842 + set f [open $path(test1) w]
1.843 + fconfigure $f -translation lf
1.844 + puts -nonewline $f a
1.845 + close $f
1.846 + set f [open $path(test1)]
1.847 + fconfigure $f -translation auto
1.848 + set x [list [gets $f line] $line [gets $f line] $line]
1.849 + close $f
1.850 + set x
1.851 +} {1 a -1 {}}
1.852 +test io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} {
1.853 + set f [open $path(test1) w]
1.854 + fconfigure $f -translation lf
1.855 + puts -nonewline $f "a\r\n"
1.856 + close $f
1.857 + set f [open $path(test1)]
1.858 + fconfigure $f -translation auto
1.859 + set x [list [gets $f line] $line [gets $f line] $line]
1.860 + close $f
1.861 + set x
1.862 +} {1 a -1 {}}
1.863 +test io-6.42 {Tcl_GetsObj: auto mode: several chars} {
1.864 + set f [open $path(test1) w]
1.865 + fconfigure $f -translation lf
1.866 + puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
1.867 + close $f
1.868 + set f [open $path(test1)]
1.869 + fconfigure $f -translation auto
1.870 + set x [list [gets $f line] $line [gets $f line] $line]
1.871 + lappend x [gets $f line] $line [gets $f line] $line [gets $f line] $line
1.872 + close $f
1.873 + set x
1.874 +} [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""]
1.875 +test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} {
1.876 + # if (chanPtr->flags & INPUT_SAW_CR)
1.877 +
1.878 + set f [open "|[list [interpreter] $path(cat)]" w+]
1.879 + fconfigure $f -translation {auto lf} -buffering none
1.880 + puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
1.881 + fconfigure $f -buffersize 16
1.882 + set x [list [gets $f]]
1.883 + fconfigure $f -blocking 0
1.884 + lappend x [gets $f line] $line [testchannel queuedcr $f]
1.885 + fconfigure $f -blocking 1
1.886 + puts -nonewline $f "\nabcd\refg\x1a"
1.887 + lappend x [gets $f line] $line [testchannel queuedcr $f]
1.888 + lappend x [gets $f line] $line
1.889 + close $f
1.890 + set x
1.891 +} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
1.892 +test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe fileevent} {
1.893 + # not (*eol == '\n')
1.894 +
1.895 + set f [open "|[list [interpreter] $path(cat)]" w+]
1.896 + fconfigure $f -translation {auto lf} -buffering none
1.897 + puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
1.898 + fconfigure $f -buffersize 16
1.899 + set x [list [gets $f]]
1.900 + fconfigure $f -blocking 0
1.901 + lappend x [gets $f line] $line [testchannel queuedcr $f]
1.902 + fconfigure $f -blocking 1
1.903 + puts -nonewline $f "abcd\refg\x1a"
1.904 + lappend x [gets $f line] $line [testchannel queuedcr $f]
1.905 + lappend x [gets $f line] $line
1.906 + close $f
1.907 + set x
1.908 +} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
1.909 +test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel openpipe fileevent} {
1.910 + # Tcl_ExternalToUtf()
1.911 +
1.912 + set f [open "|[list [interpreter] $path(cat)]" w+]
1.913 + fconfigure $f -translation {auto lf} -buffering none
1.914 + fconfigure $f -encoding unicode
1.915 + puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
1.916 + fconfigure $f -buffersize 16
1.917 + gets $f
1.918 + fconfigure $f -blocking 0
1.919 + set x [list [gets $f line] $line [testchannel queuedcr $f]]
1.920 + fconfigure $f -blocking 1
1.921 + puts -nonewline $f "\nabcd\refg"
1.922 + lappend x [gets $f line] $line [testchannel queuedcr $f]
1.923 + close $f
1.924 + set x
1.925 +} [list 15 "123456789abcdef" 1 4 "abcd" 0]
1.926 +test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel openpipe fileevent} {
1.927 + # memmove()
1.928 +
1.929 + set f [open "|[list [interpreter] $path(cat)]" w+]
1.930 + fconfigure $f -translation {auto lf} -buffering none
1.931 + puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
1.932 + fconfigure $f -buffersize 16
1.933 + gets $f
1.934 + fconfigure $f -blocking 0
1.935 + set x [list [gets $f line] $line [testchannel queuedcr $f]]
1.936 + fconfigure $f -blocking 1
1.937 + puts -nonewline $f "\n\x1a"
1.938 + lappend x [gets $f line] $line [testchannel queuedcr $f]
1.939 + close $f
1.940 + set x
1.941 +} [list 15 "123456789abcdef" 1 -1 "" 0]
1.942 +test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testchannel} {
1.943 + # (eol == dstEnd)
1.944 +
1.945 + set f [open $path(test1) w]
1.946 + fconfigure $f -translation lf
1.947 + puts -nonewline $f "123456789012345\r\nabcdefghijklmnopq"
1.948 + close $f
1.949 + set f [open $path(test1)]
1.950 + fconfigure $f -translation auto -buffersize 16
1.951 + set x [list [gets $f] [testchannel inputbuffered $f]]
1.952 + close $f
1.953 + set x
1.954 +} [list "123456789012345" 15]
1.955 +test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testchannel} {
1.956 + # PeekAhead() did not get any, so (eol >= dstEnd)
1.957 +
1.958 + set f [open $path(test1) w]
1.959 + fconfigure $f -translation lf
1.960 + puts -nonewline $f "123456789012345\r"
1.961 + close $f
1.962 + set f [open $path(test1)]
1.963 + fconfigure $f -translation auto -buffersize 16
1.964 + set x [list [gets $f] [testchannel queuedcr $f]]
1.965 + close $f
1.966 + set x
1.967 +} [list "123456789012345" 1]
1.968 +test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} {
1.969 + # if (*eol == '\n') {skip++}
1.970 +
1.971 + set f [open $path(test1) w]
1.972 + fconfigure $f -translation lf
1.973 + puts -nonewline $f "123456\r\n78901"
1.974 + close $f
1.975 + set f [open $path(test1)]
1.976 + set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
1.977 + close $f
1.978 + set x
1.979 +} [list "123456" 0 8 "78901"]
1.980 +test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} {
1.981 + # not (*eol == '\n')
1.982 +
1.983 + set f [open $path(test1) w]
1.984 + fconfigure $f -translation lf
1.985 + puts -nonewline $f "123456\r78901"
1.986 + close $f
1.987 + set f [open $path(test1)]
1.988 + set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
1.989 + close $f
1.990 + set x
1.991 +} [list "123456" 0 7 "78901"]
1.992 +test io-6.51 {Tcl_GetsObj: auto mode: \n} {
1.993 + # else if (*eol == '\n') {goto gotoeol;}
1.994 +
1.995 + set f [open $path(test1) w]
1.996 + fconfigure $f -translation lf
1.997 + puts -nonewline $f "123456\n78901"
1.998 + close $f
1.999 + set f [open $path(test1)]
1.1000 + set x [list [gets $f] [tell $f] [gets $f]]
1.1001 + close $f
1.1002 + set x
1.1003 +} [list "123456" 7 "78901"]
1.1004 +test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} {
1.1005 + # if (eof != NULL)
1.1006 +
1.1007 + set f [open $path(test1) w]
1.1008 + fconfigure $f -translation lf
1.1009 + puts -nonewline $f "123456\x1ak9012345\r"
1.1010 + close $f
1.1011 + set f [open $path(test1)]
1.1012 + fconfigure $f -eofchar \x1a
1.1013 + set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
1.1014 + close $f
1.1015 + set x
1.1016 +} [list "123456" 0 6 ""]
1.1017 +test io-6.53 {Tcl_GetsObj: device EOF} {
1.1018 + # didn't produce any bytes
1.1019 +
1.1020 + set f [open $path(test1) w]
1.1021 + close $f
1.1022 + set f [open $path(test1)]
1.1023 + set x [list [gets $f line] $line [eof $f]]
1.1024 + close $f
1.1025 + set x
1.1026 +} {-1 {} 1}
1.1027 +test io-6.54 {Tcl_GetsObj: device EOF} {
1.1028 + # got some bytes before EOF.
1.1029 +
1.1030 + set f [open $path(test1) w]
1.1031 + puts -nonewline $f abc
1.1032 + close $f
1.1033 + set f [open $path(test1)]
1.1034 + set x [list [gets $f line] $line [eof $f]]
1.1035 + close $f
1.1036 + set x
1.1037 +} {3 abc 1}
1.1038 +test io-6.55 {Tcl_GetsObj: overconverted} {
1.1039 + # Tcl_ExternalToUtf(), make sure state updated
1.1040 +
1.1041 + set f [open $path(test1) w]
1.1042 + fconfigure $f -encoding iso2022-jp
1.1043 + puts $f "there\u4e00ok\n\u4e01more bytes\nhere"
1.1044 + close $f
1.1045 + set f [open $path(test1)]
1.1046 + fconfigure $f -encoding iso2022-jp
1.1047 + set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
1.1048 + close $f
1.1049 + set x
1.1050 +} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"]
1.1051 +test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio openpipe fileevent} {
1.1052 + update
1.1053 + set f [open "|[list [interpreter] $path(cat)]" w+]
1.1054 + fconfigure $f -buffering none
1.1055 + puts -nonewline $f "foobar"
1.1056 + fconfigure $f -blocking 0
1.1057 + variable x {}
1.1058 + after 500 [namespace code { lappend x timeout }]
1.1059 + fileevent $f readable [namespace code { lappend x [gets $f] }]
1.1060 + vwait [namespace which -variable x]
1.1061 + vwait [namespace which -variable x]
1.1062 + fconfigure $f -blocking 1
1.1063 + puts -nonewline $f "baz\n"
1.1064 + after 500 [namespace code { lappend x timeout }]
1.1065 + fconfigure $f -blocking 0
1.1066 + vwait [namespace which -variable x]
1.1067 + vwait [namespace which -variable x]
1.1068 + close $f
1.1069 + set x
1.1070 +} {{} timeout foobarbaz timeout}
1.1071 +
1.1072 +test io-7.1 {FilterInputBytes: split up character at end of buffer} {
1.1073 + # (result == TCL_CONVERT_MULTIBYTE)
1.1074 +
1.1075 + set f [open $path(test1) w]
1.1076 + fconfigure $f -encoding shiftjis
1.1077 + puts $f "1234567890123\uff10\uff11\uff12\uff13\uff14\nend"
1.1078 + close $f
1.1079 + set f [open $path(test1)]
1.1080 + fconfigure $f -encoding shiftjis -buffersize 16
1.1081 + set x [gets $f]
1.1082 + close $f
1.1083 + set x
1.1084 +} "1234567890123\uff10\uff11\uff12\uff13\uff14"
1.1085 +test io-7.2 {FilterInputBytes: split up character in middle of buffer} {
1.1086 + # (bufPtr->nextAdded < bufPtr->bufLength)
1.1087 +
1.1088 + set f [open $path(test1) w]
1.1089 + fconfigure $f -encoding binary
1.1090 + puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82"
1.1091 + close $f
1.1092 + set f [open $path(test1)]
1.1093 + fconfigure $f -encoding shiftjis
1.1094 + set x [list [gets $f line] $line [eof $f]]
1.1095 + close $f
1.1096 + set x
1.1097 +} [list 10 "1234567890" 0]
1.1098 +test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} {
1.1099 + set f [open $path(test1) w]
1.1100 + fconfigure $f -encoding binary
1.1101 + puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82"
1.1102 + close $f
1.1103 + set f [open $path(test1)]
1.1104 + fconfigure $f -encoding shiftjis
1.1105 + set x [list [gets $f line] $line]
1.1106 + lappend x [tell $f] [testchannel inputbuffered $f] [eof $f]
1.1107 + lappend x [gets $f line] $line
1.1108 + close $f
1.1109 + set x
1.1110 +} [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""]
1.1111 +test io-7.4 {FilterInputBytes: recover from split up character} {stdio openpipe fileevent} {
1.1112 + set f [open "|[list [interpreter] $path(cat)]" w+]
1.1113 + fconfigure $f -encoding binary -buffering none
1.1114 + puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82"
1.1115 + fconfigure $f -encoding shiftjis -blocking 0
1.1116 + fileevent $f read [namespace code "ready $f"]
1.1117 + variable x {}
1.1118 + proc ready {f} {
1.1119 + variable x
1.1120 + lappend x [gets $f line] $line [fblocked $f]
1.1121 + }
1.1122 + vwait [namespace which -variable x]
1.1123 + fconfigure $f -encoding binary -blocking 1
1.1124 + puts $f "\x51\x82\x52"
1.1125 + fconfigure $f -encoding shiftjis
1.1126 + vwait [namespace which -variable x]
1.1127 + close $f
1.1128 + set x
1.1129 +} [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0]
1.1130 +
1.1131 +test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} {
1.1132 + # (bufPtr->nextPtr == NULL)
1.1133 +
1.1134 + set f [open $path(test1) w]
1.1135 + fconfigure $f -encoding ascii -translation lf
1.1136 + puts -nonewline $f "123456789012345\r\n2345678"
1.1137 + close $f
1.1138 + set f [open $path(test1)]
1.1139 + fconfigure $f -encoding ascii -translation auto -buffersize 16
1.1140 + # here
1.1141 + gets $f
1.1142 + set x [testchannel inputbuffered $f]
1.1143 + close $f
1.1144 + set x
1.1145 +} "7"
1.1146 +test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel openpipe fileevent} {
1.1147 + # not (bufPtr->nextPtr == NULL)
1.1148 +
1.1149 + set f [open "|[list [interpreter] $path(cat)]" w+]
1.1150 + fconfigure $f -translation lf -encoding ascii -buffering none
1.1151 + puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz"
1.1152 + variable x {}
1.1153 + fileevent $f read [namespace code "ready $f"]
1.1154 + proc ready {f} {
1.1155 + variable x
1.1156 + lappend x [gets $f line] $line [testchannel inputbuffered $f]
1.1157 + }
1.1158 + fconfigure $f -encoding unicode -buffersize 16 -blocking 0
1.1159 + vwait [namespace which -variable x]
1.1160 + fconfigure $f -translation auto -encoding ascii -blocking 1
1.1161 + # here
1.1162 + vwait [namespace which -variable x]
1.1163 + close $f
1.1164 + set x
1.1165 +} [list -1 "" 42 15 "123456789012345" 25]
1.1166 +test io-8.3 {PeekAhead: no cached data available} {stdio testchannel openpipe fileevent} {
1.1167 + # (bytesLeft == 0)
1.1168 +
1.1169 + set f [open "|[list [interpreter] $path(cat)]" w+]
1.1170 + fconfigure $f -translation {auto binary}
1.1171 + puts -nonewline $f "abcdefghijklmno\r"
1.1172 + flush $f
1.1173 + set x [list [gets $f line] $line [testchannel queuedcr $f]]
1.1174 + close $f
1.1175 + set x
1.1176 +} [list 15 "abcdefghijklmno" 1]
1.1177 +set a "123456789012345678901234567890"
1.1178 +append a "123456789012345678901234567890"
1.1179 +append a "1234567890123456789012345678901"
1.1180 +test io-8.4 {PeekAhead: cached data available in this buffer} {
1.1181 + # not (bytesLeft == 0)
1.1182 +
1.1183 + set f [open $path(test1) w+]
1.1184 + fconfigure $f -translation binary
1.1185 + puts $f "${a}\r\nabcdef"
1.1186 + close $f
1.1187 + set f [open $path(test1)]
1.1188 + fconfigure $f -encoding binary -translation auto
1.1189 +
1.1190 + # "${a}\r" was converted in one operation (because ENCODING_LINESIZE
1.1191 + # is 30). To check if "\n" follows, calls PeekAhead and determines
1.1192 + # that cached data is available in buffer w/o having to call driver.
1.1193 +
1.1194 + set x [gets $f]
1.1195 + close $f
1.1196 + set x
1.1197 +} $a
1.1198 +unset a
1.1199 +test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe fileevent} {
1.1200 + # (bufPtr->nextAdded < bufPtr->length)
1.1201 +
1.1202 + set f [open "|[list [interpreter] $path(cat)]" w+]
1.1203 + fconfigure $f -translation {auto binary}
1.1204 + puts -nonewline $f "abcdefghijklmno\r"
1.1205 + flush $f
1.1206 + # here
1.1207 + set x [list [gets $f line] $line [testchannel queuedcr $f]]
1.1208 + close $f
1.1209 + set x
1.1210 +} {15 abcdefghijklmno 1}
1.1211 +test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe fileevent} {
1.1212 + # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0)
1.1213 +
1.1214 + set f [open "|[list [interpreter] $path(cat)]" w+]
1.1215 + fconfigure $f -translation {auto binary} -buffersize 16
1.1216 + puts -nonewline $f "abcdefghijklmno\r"
1.1217 + flush $f
1.1218 + # here
1.1219 + set x [list [gets $f line] $line [testchannel queuedcr $f]]
1.1220 + close $f
1.1221 + set x
1.1222 +} {15 abcdefghijklmno 1}
1.1223 +test io-8.7 {PeekAhead: cleanup} {stdio testchannel openpipe fileevent} {
1.1224 + # Make sure bytes are removed from buffer.
1.1225 +
1.1226 + set f [open "|[list [interpreter] $path(cat)]" w+]
1.1227 + fconfigure $f -translation {auto binary} -buffering none
1.1228 + puts -nonewline $f "abcdefghijklmno\r"
1.1229 + # here
1.1230 + set x [list [gets $f line] $line [testchannel queuedcr $f]]
1.1231 + puts -nonewline $f "\x1a"
1.1232 + lappend x [gets $f line] $line
1.1233 + close $f
1.1234 + set x
1.1235 +} {15 abcdefghijklmno 1 -1 {}}
1.1236 +
1.1237 +
1.1238 +test io-9.1 {CommonGetsCleanup} {
1.1239 +} {}
1.1240 +
1.1241 +test io-10.1 {Tcl_ReadChars: CheckChannelErrors} {
1.1242 + # no test, need to cause an async error.
1.1243 +} {}
1.1244 +test io-10.2 {Tcl_ReadChars: loop until enough copied} {
1.1245 + # one time
1.1246 + # for (copied = 0; (unsigned) toRead > 0; )
1.1247 +
1.1248 + set f [open $path(test1) w]
1.1249 + puts $f abcdefghijklmnop
1.1250 + close $f
1.1251 +
1.1252 + set f [open $path(test1)]
1.1253 + set x [read $f 5]
1.1254 + close $f
1.1255 + set x
1.1256 +} {abcde}
1.1257 +test io-10.3 {Tcl_ReadChars: loop until enough copied} {
1.1258 + # multiple times
1.1259 + # for (copied = 0; (unsigned) toRead > 0; )
1.1260 +
1.1261 + set f [open $path(test1) w]
1.1262 + puts $f abcdefghijklmnopqrstuvwxyz
1.1263 + close $f
1.1264 +
1.1265 + set f [open $path(test1)]
1.1266 + fconfigure $f -buffersize 16
1.1267 + # here
1.1268 + set x [read $f 19]
1.1269 + close $f
1.1270 + set x
1.1271 +} {abcdefghijklmnopqrs}
1.1272 +test io-10.4 {Tcl_ReadChars: no more in channel buffer} {
1.1273 + # (copiedNow < 0)
1.1274 +
1.1275 + set f [open $path(test1) w]
1.1276 + puts -nonewline $f abcdefghijkl
1.1277 + close $f
1.1278 +
1.1279 + set f [open $path(test1)]
1.1280 + # here
1.1281 + set x [read $f 1000]
1.1282 + close $f
1.1283 + set x
1.1284 +} {abcdefghijkl}
1.1285 +test io-10.5 {Tcl_ReadChars: stop on EOF} {
1.1286 + # (chanPtr->flags & CHANNEL_EOF)
1.1287 +
1.1288 + set f [open $path(test1) w]
1.1289 + puts -nonewline $f abcdefghijkl
1.1290 + close $f
1.1291 +
1.1292 + set f [open $path(test1)]
1.1293 + # here
1.1294 + set x [read $f 1000]
1.1295 + close $f
1.1296 + set x
1.1297 +} {abcdefghijkl}
1.1298 +
1.1299 +test io-11.1 {ReadBytes: want to read a lot} {
1.1300 + # ((unsigned) toRead > (unsigned) srcLen)
1.1301 +
1.1302 + set f [open $path(test1) w]
1.1303 + puts -nonewline $f abcdefghijkl
1.1304 + close $f
1.1305 + set f [open $path(test1)]
1.1306 + fconfigure $f -encoding binary
1.1307 + # here
1.1308 + set x [read $f 1000]
1.1309 + close $f
1.1310 + set x
1.1311 +} {abcdefghijkl}
1.1312 +test io-11.2 {ReadBytes: want to read all} {
1.1313 + # ((unsigned) toRead > (unsigned) srcLen)
1.1314 +
1.1315 + set f [open $path(test1) w]
1.1316 + puts -nonewline $f abcdefghijkl
1.1317 + close $f
1.1318 + set f [open $path(test1)]
1.1319 + fconfigure $f -encoding binary
1.1320 + # here
1.1321 + set x [read $f]
1.1322 + close $f
1.1323 + set x
1.1324 +} {abcdefghijkl}
1.1325 +test io-11.3 {ReadBytes: allocate more space} {
1.1326 + # (toRead > length - offset - 1)
1.1327 +
1.1328 + set f [open $path(test1) w]
1.1329 + puts -nonewline $f abcdefghijklmnopqrstuvwxyz
1.1330 + close $f
1.1331 + set f [open $path(test1)]
1.1332 + fconfigure $f -buffersize 16 -encoding binary
1.1333 + # here
1.1334 + set x [read $f]
1.1335 + close $f
1.1336 + set x
1.1337 +} {abcdefghijklmnopqrstuvwxyz}
1.1338 +test io-11.4 {ReadBytes: EOF char found} {
1.1339 + # (TranslateInputEOL() != 0)
1.1340 +
1.1341 + set f [open $path(test1) w]
1.1342 + puts $f abcdefghijklmnopqrstuvwxyz
1.1343 + close $f
1.1344 + set f [open $path(test1)]
1.1345 + fconfigure $f -eofchar m -encoding binary
1.1346 + # here
1.1347 + set x [list [read $f] [eof $f] [read $f] [eof $f]]
1.1348 + close $f
1.1349 + set x
1.1350 +} [list "abcdefghijkl" 1 "" 1]
1.1351 +
1.1352 +test io-12.1 {ReadChars: want to read a lot} {
1.1353 + # ((unsigned) toRead > (unsigned) srcLen)
1.1354 +
1.1355 + set f [open $path(test1) w]
1.1356 + puts -nonewline $f abcdefghijkl
1.1357 + close $f
1.1358 + set f [open $path(test1)]
1.1359 + # here
1.1360 + set x [read $f 1000]
1.1361 + close $f
1.1362 + set x
1.1363 +} {abcdefghijkl}
1.1364 +test io-12.2 {ReadChars: want to read all} {
1.1365 + # ((unsigned) toRead > (unsigned) srcLen)
1.1366 +
1.1367 + set f [open $path(test1) w]
1.1368 + puts -nonewline $f abcdefghijkl
1.1369 + close $f
1.1370 + set f [open $path(test1)]
1.1371 + # here
1.1372 + set x [read $f]
1.1373 + close $f
1.1374 + set x
1.1375 +} {abcdefghijkl}
1.1376 +test io-12.3 {ReadChars: allocate more space} {
1.1377 + # (toRead > length - offset - 1)
1.1378 +
1.1379 + set f [open $path(test1) w]
1.1380 + puts -nonewline $f abcdefghijklmnopqrstuvwxyz
1.1381 + close $f
1.1382 + set f [open $path(test1)]
1.1383 + fconfigure $f -buffersize 16
1.1384 + # here
1.1385 + set x [read $f]
1.1386 + close $f
1.1387 + set x
1.1388 +} {abcdefghijklmnopqrstuvwxyz}
1.1389 +test io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} {
1.1390 + # (srcRead == 0)
1.1391 +
1.1392 + set f [open "|[list [interpreter] $path(cat)]" w+]
1.1393 + fconfigure $f -encoding binary -buffering none -buffersize 16
1.1394 + puts -nonewline $f "123456789012345\x96"
1.1395 + fconfigure $f -encoding shiftjis -blocking 0
1.1396 +
1.1397 + fileevent $f read [namespace code "ready $f"]
1.1398 + proc ready {f} {
1.1399 + variable x
1.1400 + lappend x [read $f] [testchannel inputbuffered $f]
1.1401 + }
1.1402 + variable x {}
1.1403 +
1.1404 + fconfigure $f -encoding shiftjis
1.1405 + vwait [namespace which -variable x]
1.1406 + fconfigure $f -encoding binary -blocking 1
1.1407 + puts -nonewline $f "\x7b"
1.1408 + after 500 ;# Give the cat process time to catch up
1.1409 + fconfigure $f -encoding shiftjis -blocking 0
1.1410 + vwait [namespace which -variable x]
1.1411 + close $f
1.1412 + set x
1.1413 +} [list "123456789012345" 1 "\u672c" 0]
1.1414 +test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe fileevent} {
1.1415 + set path(test1) [makeFile {
1.1416 + fconfigure stdout -encoding binary -buffering none
1.1417 + gets stdin; puts -nonewline "\xe7"
1.1418 + gets stdin; puts -nonewline "\x89"
1.1419 + gets stdin; puts -nonewline "\xa6"
1.1420 + } test1]
1.1421 + set f [open "|[list [interpreter] $path(test1)]" r+]
1.1422 + fileevent $f readable [namespace code {
1.1423 + lappend x [read $f]
1.1424 + if {[eof $f]} {
1.1425 + lappend x eof
1.1426 + }
1.1427 + }]
1.1428 + puts $f "go1"
1.1429 + flush $f
1.1430 + fconfigure $f -blocking 0 -encoding utf-8
1.1431 + variable x {}
1.1432 + vwait [namespace which -variable x]
1.1433 + after 500 [namespace code { lappend x timeout }]
1.1434 + vwait [namespace which -variable x]
1.1435 + puts $f "go2"
1.1436 + flush $f
1.1437 + vwait [namespace which -variable x]
1.1438 + after 500 [namespace code { lappend x timeout }]
1.1439 + vwait [namespace which -variable x]
1.1440 + puts $f "go3"
1.1441 + flush $f
1.1442 + vwait [namespace which -variable x]
1.1443 + vwait [namespace which -variable x]
1.1444 + lappend x [catch {close $f} msg] $msg
1.1445 + set x
1.1446 +} "{} timeout {} timeout \u7266 {} eof 0 {}"
1.1447 +
1.1448 +test io-13.1 {TranslateInputEOL: cr mode} {} {
1.1449 + set f [open $path(test1) w]
1.1450 + fconfigure $f -translation lf
1.1451 + puts -nonewline $f "abcd\rdef\r"
1.1452 + close $f
1.1453 + set f [open $path(test1)]
1.1454 + fconfigure $f -translation cr
1.1455 + set x [read $f]
1.1456 + close $f
1.1457 + set x
1.1458 +} "abcd\ndef\n"
1.1459 +test io-13.2 {TranslateInputEOL: crlf mode} {
1.1460 + set f [open $path(test1) w]
1.1461 + fconfigure $f -translation lf
1.1462 + puts -nonewline $f "abcd\r\ndef\r\n"
1.1463 + close $f
1.1464 + set f [open $path(test1)]
1.1465 + fconfigure $f -translation crlf
1.1466 + set x [read $f]
1.1467 + close $f
1.1468 + set x
1.1469 +} "abcd\ndef\n"
1.1470 +test io-13.3 {TranslateInputEOL: crlf mode: naked cr} {
1.1471 + # (src >= srcMax)
1.1472 +
1.1473 + set f [open $path(test1) w]
1.1474 + fconfigure $f -translation lf
1.1475 + puts -nonewline $f "abcd\r\ndef\r"
1.1476 + close $f
1.1477 + set f [open $path(test1)]
1.1478 + fconfigure $f -translation crlf
1.1479 + set x [read $f]
1.1480 + close $f
1.1481 + set x
1.1482 +} "abcd\ndef\r"
1.1483 +test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} {
1.1484 + # (src >= srcMax)
1.1485 +
1.1486 + set f [open $path(test1) w]
1.1487 + fconfigure $f -translation lf
1.1488 + puts -nonewline $f "abcd\r\ndef\rfgh"
1.1489 + close $f
1.1490 + set f [open $path(test1)]
1.1491 + fconfigure $f -translation crlf
1.1492 + set x [read $f]
1.1493 + close $f
1.1494 + set x
1.1495 +} "abcd\ndef\rfgh"
1.1496 +test io-13.5 {TranslateInputEOL: crlf mode: naked lf} {
1.1497 + # (src >= srcMax)
1.1498 +
1.1499 + set f [open $path(test1) w]
1.1500 + fconfigure $f -translation lf
1.1501 + puts -nonewline $f "abcd\r\ndef\nfgh"
1.1502 + close $f
1.1503 + set f [open $path(test1)]
1.1504 + fconfigure $f -translation crlf
1.1505 + set x [read $f]
1.1506 + close $f
1.1507 + set x
1.1508 +} "abcd\ndef\nfgh"
1.1509 +test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel openpipe fileevent} {
1.1510 + # (chanPtr->flags & INPUT_SAW_CR)
1.1511 + # This test may fail on slower machines.
1.1512 +
1.1513 + set f [open "|[list [interpreter] $path(cat)]" w+]
1.1514 + fconfigure $f -blocking 0 -buffering none -translation {auto lf}
1.1515 +
1.1516 + fileevent $f read [namespace code "ready $f"]
1.1517 + proc ready {f} {
1.1518 + variable x
1.1519 + lappend x [read $f] [testchannel queuedcr $f]
1.1520 + }
1.1521 + variable x {}
1.1522 + variable y {}
1.1523 +
1.1524 + puts -nonewline $f "abcdefghj\r"
1.1525 + after 500 [namespace code {set y ok}]
1.1526 + vwait [namespace which -variable y]
1.1527 +
1.1528 + puts -nonewline $f "\n01234"
1.1529 + after 500 [namespace code {set y ok}]
1.1530 + vwait [namespace which -variable y]
1.1531 +
1.1532 + close $f
1.1533 + set x
1.1534 +} [list "abcdefghj\n" 1 "01234" 0]
1.1535 +test io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel openpipe} {
1.1536 + # (src >= srcMax)
1.1537 +
1.1538 + set f [open $path(test1) w]
1.1539 + fconfigure $f -translation lf
1.1540 + puts -nonewline $f "abcd\r"
1.1541 + close $f
1.1542 + set f [open $path(test1)]
1.1543 + fconfigure $f -translation auto
1.1544 + set x [list [read $f] [testchannel queuedcr $f]]
1.1545 + close $f
1.1546 + set x
1.1547 +} [list "abcd\n" 1]
1.1548 +test io-13.8 {TranslateInputEOL: auto mode: \r\n} {
1.1549 + # (*src == '\n')
1.1550 +
1.1551 + set f [open $path(test1) w]
1.1552 + fconfigure $f -translation lf
1.1553 + puts -nonewline $f "abcd\r\ndef"
1.1554 + close $f
1.1555 + set f [open $path(test1)]
1.1556 + fconfigure $f -translation auto
1.1557 + set x [read $f]
1.1558 + close $f
1.1559 + set x
1.1560 +} "abcd\ndef"
1.1561 +test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} {
1.1562 + set f [open $path(test1) w]
1.1563 + fconfigure $f -translation lf
1.1564 + puts -nonewline $f "abcd\rdef"
1.1565 + close $f
1.1566 + set f [open $path(test1)]
1.1567 + fconfigure $f -translation auto
1.1568 + set x [read $f]
1.1569 + close $f
1.1570 + set x
1.1571 +} "abcd\ndef"
1.1572 +test io-13.10 {TranslateInputEOL: auto mode: \n} {
1.1573 + # not (*src == '\r')
1.1574 +
1.1575 + set f [open $path(test1) w]
1.1576 + fconfigure $f -translation lf
1.1577 + puts -nonewline $f "abcd\ndef"
1.1578 + close $f
1.1579 + set f [open $path(test1)]
1.1580 + fconfigure $f -translation auto
1.1581 + set x [read $f]
1.1582 + close $f
1.1583 + set x
1.1584 +} "abcd\ndef"
1.1585 +test io-13.11 {TranslateInputEOL: EOF char} {
1.1586 + # (*chanPtr->inEofChar != '\0')
1.1587 +
1.1588 + set f [open $path(test1) w]
1.1589 + fconfigure $f -translation lf
1.1590 + puts -nonewline $f "abcd\ndefgh"
1.1591 + close $f
1.1592 + set f [open $path(test1)]
1.1593 + fconfigure $f -translation auto -eofchar e
1.1594 + set x [read $f]
1.1595 + close $f
1.1596 + set x
1.1597 +} "abcd\nd"
1.1598 +test io-13.12 {TranslateInputEOL: find EOF char in src} {
1.1599 + # (*chanPtr->inEofChar != '\0')
1.1600 +
1.1601 + set f [open $path(test1) w]
1.1602 + fconfigure $f -translation lf
1.1603 + puts -nonewline $f "\r\n\r\n\r\nab\r\n\r\ndef\r\n\r\n\r\n"
1.1604 + close $f
1.1605 + set f [open $path(test1)]
1.1606 + fconfigure $f -translation auto -eofchar e
1.1607 + set x [read $f]
1.1608 + close $f
1.1609 + set x
1.1610 +} "\n\n\nab\n\nd"
1.1611 +
1.1612 +# Test standard handle management. The functions tested are
1.1613 +# Tcl_SetStdChannel and Tcl_GetStdChannel. Incidentally we are
1.1614 +# also testing channel table management.
1.1615 +
1.1616 +if {[info commands testchannel] != ""} {
1.1617 + if {$tcl_platform(platform) == "macintosh"} {
1.1618 + set consoleFileNames [list console0 console1 console2]
1.1619 + } else {
1.1620 + set consoleFileNames [lsort [testchannel open]]
1.1621 + }
1.1622 +} else {
1.1623 + # just to avoid an error
1.1624 + set consoleFileNames [list]
1.1625 +}
1.1626 +
1.1627 +test io-14.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} {testchannel} {
1.1628 + set l ""
1.1629 + lappend l [fconfigure stdin -buffering]
1.1630 + lappend l [fconfigure stdout -buffering]
1.1631 + lappend l [fconfigure stderr -buffering]
1.1632 + lappend l [lsort [testchannel open]]
1.1633 + set l
1.1634 +} [list line line none $consoleFileNames]
1.1635 +test io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} {
1.1636 + interp create x
1.1637 + set l ""
1.1638 + lappend l [x eval {fconfigure stdin -buffering}]
1.1639 + lappend l [x eval {fconfigure stdout -buffering}]
1.1640 + lappend l [x eval {fconfigure stderr -buffering}]
1.1641 + interp delete x
1.1642 + set l
1.1643 +} {line line none}
1.1644 +
1.1645 +set path(test3) [makeFile {} test3]
1.1646 +
1.1647 +test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec openpipe} {
1.1648 + set f [open $path(test1) w]
1.1649 + puts -nonewline $f {
1.1650 + close stdin
1.1651 + close stdout
1.1652 + close stderr
1.1653 + set f [}
1.1654 + puts $f [list open $path(test1) r]]
1.1655 + puts $f "set f2 \[[list open $path(test2) w]]"
1.1656 + puts $f "set f3 \[[list open $path(test3) w]]"
1.1657 + puts $f { puts stdout [gets stdin]
1.1658 + puts stdout out
1.1659 + puts stderr err
1.1660 + close $f
1.1661 + close $f2
1.1662 + close $f3
1.1663 + }
1.1664 + close $f
1.1665 + set result [exec [interpreter] $path(test1)]
1.1666 + set f [open $path(test2) r]
1.1667 + set f2 [open $path(test3) r]
1.1668 + lappend result [read $f] [read $f2]
1.1669 + close $f
1.1670 + close $f2
1.1671 + set result
1.1672 +} {{
1.1673 +out
1.1674 +} {err
1.1675 +}}
1.1676 +# This test relies on the fact that the smallest available fd is used first.
1.1677 +test io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec unixOnly} {
1.1678 + set f [open $path(test1) w]
1.1679 + puts -nonewline $f { close stdin
1.1680 + close stdout
1.1681 + close stderr
1.1682 + set f [}
1.1683 + puts $f [list open $path(test1) r]]
1.1684 + puts $f "set f2 \[[list open $path(test2) w]]"
1.1685 + puts $f "set f3 \[[list open $path(test3) w]]"
1.1686 + puts $f { puts stdout [gets stdin]
1.1687 + puts stdout $f2
1.1688 + puts stderr $f3
1.1689 + close $f
1.1690 + close $f2
1.1691 + close $f3
1.1692 + }
1.1693 + close $f
1.1694 + set result [exec [interpreter] $path(test1)]
1.1695 + set f [open $path(test2) r]
1.1696 + set f2 [open $path(test3) r]
1.1697 + lappend result [read $f] [read $f2]
1.1698 + close $f
1.1699 + close $f2
1.1700 + set result
1.1701 +} {{ close stdin
1.1702 +file1
1.1703 +} {file2
1.1704 +}}
1.1705 +catch {interp delete z}
1.1706 +test io-14.5 {Tcl_GetChannel: stdio name translation} {
1.1707 + interp create z
1.1708 + eof stdin
1.1709 + catch {z eval flush stdin} msg1
1.1710 + catch {z eval close stdin} msg2
1.1711 + catch {z eval flush stdin} msg3
1.1712 + set result [list $msg1 $msg2 $msg3]
1.1713 + interp delete z
1.1714 + set result
1.1715 +} {{channel "stdin" wasn't opened for writing} {} {can not find channel named "stdin"}}
1.1716 +test io-14.6 {Tcl_GetChannel: stdio name translation} {
1.1717 + interp create z
1.1718 + eof stdout
1.1719 + catch {z eval flush stdout} msg1
1.1720 + catch {z eval close stdout} msg2
1.1721 + catch {z eval flush stdout} msg3
1.1722 + set result [list $msg1 $msg2 $msg3]
1.1723 + interp delete z
1.1724 + set result
1.1725 +} {{} {} {can not find channel named "stdout"}}
1.1726 +test io-14.7 {Tcl_GetChannel: stdio name translation} {
1.1727 + interp create z
1.1728 + eof stderr
1.1729 + catch {z eval flush stderr} msg1
1.1730 + catch {z eval close stderr} msg2
1.1731 + catch {z eval flush stderr} msg3
1.1732 + set result [list $msg1 $msg2 $msg3]
1.1733 + interp delete z
1.1734 + set result
1.1735 +} {{} {} {can not find channel named "stderr"}}
1.1736 +
1.1737 +set path(script) [makeFile {} script]
1.1738 +
1.1739 +test io-14.8 {reuse of stdio special channels} {stdio openpipe} {
1.1740 + file delete $path(script)
1.1741 + file delete $path(test1)
1.1742 + set f [open $path(script) w]
1.1743 + puts -nonewline $f {
1.1744 + close stderr
1.1745 + set f [}
1.1746 + puts $f [list open $path(test1) w]]
1.1747 + puts -nonewline $f {
1.1748 + puts stderr hello
1.1749 + close $f
1.1750 + set f [}
1.1751 + puts $f [list open $path(test1) r]]
1.1752 + puts $f {
1.1753 + puts [gets $f]
1.1754 + }
1.1755 + close $f
1.1756 + set f [open "|[list [interpreter] $path(script)]" r]
1.1757 + set c [gets $f]
1.1758 + close $f
1.1759 + set c
1.1760 +} hello
1.1761 +
1.1762 +test io-14.9 {reuse of stdio special channels} {stdio openpipe fileevent} {
1.1763 + file delete $path(script)
1.1764 + file delete $path(test1)
1.1765 + set f [open $path(script) w]
1.1766 + puts $f {
1.1767 + array set path [lindex $argv 0]
1.1768 + set f [open $path(test1) w]
1.1769 + puts $f hello
1.1770 + close $f
1.1771 + close stderr
1.1772 + set f [open "|[list [info nameofexecutable] $path(cat) $path(test1)]" r]
1.1773 + puts [gets $f]
1.1774 + }
1.1775 + close $f
1.1776 + set f [open "|[list [interpreter] $path(script) [array get path]]" r]
1.1777 + set c [gets $f]
1.1778 + close $f
1.1779 + # Added delay to give Windows time to stop the spawned process and clean
1.1780 + # up its grip on the file test1. Added delete as proper test cleanup.
1.1781 + # The failing tests were 18.1 and 18.2 as first re-users of file "test1".
1.1782 + after 10000
1.1783 + file delete $path(script)
1.1784 + file delete $path(test1)
1.1785 + set c
1.1786 +} hello
1.1787 +
1.1788 +test io-15.1 {Tcl_CreateCloseHandler} {
1.1789 +} {}
1.1790 +
1.1791 +test io-16.1 {Tcl_DeleteCloseHandler} {
1.1792 +} {}
1.1793 +
1.1794 +# Test channel table management. The functions tested are
1.1795 +# GetChannelTable, DeleteChannelTable, Tcl_RegisterChannel,
1.1796 +# Tcl_UnregisterChannel, Tcl_GetChannel and Tcl_CreateChannel.
1.1797 +#
1.1798 +# These functions use "eof stdin" to ensure that the standard
1.1799 +# channels are added to the channel table of the interpreter.
1.1800 +
1.1801 +test io-17.1 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} {
1.1802 + set l1 [testchannel refcount stdin]
1.1803 + eof stdin
1.1804 + interp create x
1.1805 + set l ""
1.1806 + lappend l [expr [testchannel refcount stdin] - $l1]
1.1807 + x eval {eof stdin}
1.1808 + lappend l [expr [testchannel refcount stdin] - $l1]
1.1809 + interp delete x
1.1810 + lappend l [expr [testchannel refcount stdin] - $l1]
1.1811 + set l
1.1812 +} {0 1 0}
1.1813 +test io-17.2 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} {
1.1814 + set l1 [testchannel refcount stdout]
1.1815 + eof stdin
1.1816 + interp create x
1.1817 + set l ""
1.1818 + lappend l [expr [testchannel refcount stdout] - $l1]
1.1819 + x eval {eof stdout}
1.1820 + lappend l [expr [testchannel refcount stdout] - $l1]
1.1821 + interp delete x
1.1822 + lappend l [expr [testchannel refcount stdout] - $l1]
1.1823 + set l
1.1824 +} {0 1 0}
1.1825 +test io-17.3 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} {
1.1826 + set l1 [testchannel refcount stderr]
1.1827 + eof stdin
1.1828 + interp create x
1.1829 + set l ""
1.1830 + lappend l [expr [testchannel refcount stderr] - $l1]
1.1831 + x eval {eof stderr}
1.1832 + lappend l [expr [testchannel refcount stderr] - $l1]
1.1833 + interp delete x
1.1834 + lappend l [expr [testchannel refcount stderr] - $l1]
1.1835 + set l
1.1836 +} {0 1 0}
1.1837 +
1.1838 +test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
1.1839 + file delete $path(test1)
1.1840 + set l ""
1.1841 + set f [open $path(test1) w]
1.1842 + lappend l [lindex [testchannel info $f] 15]
1.1843 + close $f
1.1844 + if {[catch {lindex [testchannel info $f] 15} msg]} {
1.1845 + lappend l $msg
1.1846 + } else {
1.1847 + lappend l "very broken: $f found after being closed"
1.1848 + }
1.1849 + string compare [string tolower $l] \
1.1850 + [list 1 [format "can not find channel named \"%s\"" $f]]
1.1851 +} 0
1.1852 +test io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
1.1853 + file delete $path(test1)
1.1854 + set l ""
1.1855 + set f [open $path(test1) w]
1.1856 + lappend l [lindex [testchannel info $f] 15]
1.1857 + interp create x
1.1858 + interp share "" $f x
1.1859 + lappend l [lindex [testchannel info $f] 15]
1.1860 + x eval close $f
1.1861 + lappend l [lindex [testchannel info $f] 15]
1.1862 + interp delete x
1.1863 + lappend l [lindex [testchannel info $f] 15]
1.1864 + close $f
1.1865 + if {[catch {lindex [testchannel info $f] 15} msg]} {
1.1866 + lappend l $msg
1.1867 + } else {
1.1868 + lappend l "very broken: $f found after being closed"
1.1869 + }
1.1870 + string compare [string tolower $l] \
1.1871 + [list 1 2 1 1 [format "can not find channel named \"%s\"" $f]]
1.1872 +} 0
1.1873 +test io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
1.1874 + file delete $path(test1)
1.1875 + set l ""
1.1876 + set f [open $path(test1) w]
1.1877 + lappend l [lindex [testchannel info $f] 15]
1.1878 + interp create x
1.1879 + interp share "" $f x
1.1880 + lappend l [lindex [testchannel info $f] 15]
1.1881 + interp delete x
1.1882 + lappend l [lindex [testchannel info $f] 15]
1.1883 + close $f
1.1884 + if {[catch {lindex [testchannel info $f] 15} msg]} {
1.1885 + lappend l $msg
1.1886 + } else {
1.1887 + lappend l "very broken: $f found after being closed"
1.1888 + }
1.1889 + string compare [string tolower $l] \
1.1890 + [list 1 2 1 [format "can not find channel named \"%s\"" $f]]
1.1891 +} 0
1.1892 +
1.1893 +test io-19.1 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} {
1.1894 + eof stdin
1.1895 +} 0
1.1896 +test io-19.2 {testing Tcl_GetChannel, user opened handle} {
1.1897 + file delete $path(test1)
1.1898 + set f [open $path(test1) w]
1.1899 + set x [eof $f]
1.1900 + close $f
1.1901 + set x
1.1902 +} 0
1.1903 +test io-19.3 {Tcl_GetChannel, channel not found} {
1.1904 + list [catch {eof file34} msg] $msg
1.1905 +} {1 {can not find channel named "file34"}}
1.1906 +test io-19.4 {Tcl_CreateChannel, insertion into channel table} {testchannel} {
1.1907 + file delete $path(test1)
1.1908 + set f [open $path(test1) w]
1.1909 + set l ""
1.1910 + lappend l [eof $f]
1.1911 + close $f
1.1912 + if {[catch {lindex [testchannel info $f] 15} msg]} {
1.1913 + lappend l $msg
1.1914 + } else {
1.1915 + lappend l "very broken: $f found after being closed"
1.1916 + }
1.1917 + string compare [string tolower $l] \
1.1918 + [list 0 [format "can not find channel named \"%s\"" $f]]
1.1919 +} 0
1.1920 +
1.1921 +test io-20.1 {Tcl_CreateChannel: initial settings} {
1.1922 + set a [open $path(test2) w]
1.1923 + set old [encoding system]
1.1924 + encoding system ascii
1.1925 + set f [open $path(test1) w]
1.1926 + set x [fconfigure $f -encoding]
1.1927 + close $f
1.1928 + encoding system $old
1.1929 + close $a
1.1930 + set x
1.1931 +} {ascii}
1.1932 +test io-20.2 {Tcl_CreateChannel: initial settings} {pcOnly} {
1.1933 + set f [open $path(test1) w+]
1.1934 + set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
1.1935 + close $f
1.1936 + set x
1.1937 +} [list [list \x1a ""] {auto crlf}]
1.1938 +test io-20.3 {Tcl_CreateChannel: initial settings} {unixOnly} {
1.1939 + set f [open $path(test1) w+]
1.1940 + set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
1.1941 + close $f
1.1942 + set x
1.1943 +} {{{} {}} {auto lf}}
1.1944 +test io-20.4 {Tcl_CreateChannel: initial settings} {macOnly} {
1.1945 + set f [open $path(test1) w+]
1.1946 + set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
1.1947 + close $f
1.1948 + set x
1.1949 +} {{{} {}} {auto cr}}
1.1950 +
1.1951 +set path(stdout) [makeFile {} stdout]
1.1952 +
1.1953 +test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio openpipe} {
1.1954 + set f [open $path(script) w]
1.1955 + puts -nonewline $f {
1.1956 + close stdout
1.1957 + set f1 [}
1.1958 + puts $f [list open $path(stdout) w]]
1.1959 + puts $f {
1.1960 + fconfigure $f1 -buffersize 777
1.1961 + puts stderr [fconfigure stdout -buffersize]
1.1962 + }
1.1963 + close $f
1.1964 + set f [open "|[list [interpreter] $path(script)]"]
1.1965 + catch {close $f} msg
1.1966 + set msg
1.1967 +} {777}
1.1968 +
1.1969 +test io-21.1 {CloseChannelsOnExit} {
1.1970 +} {}
1.1971 +
1.1972 +# Test management of attributes associated with a channel, such as
1.1973 +# its default translation, its name and type, etc. The functions
1.1974 +# tested in this group are Tcl_GetChannelName,
1.1975 +# Tcl_GetChannelType and Tcl_GetChannelFile. Tcl_GetChannelInstanceData
1.1976 +# not tested because files do not use the instance data.
1.1977 +
1.1978 +test io-22.1 {Tcl_GetChannelMode} {
1.1979 + # Not used anywhere in Tcl.
1.1980 +} {}
1.1981 +
1.1982 +test io-23.1 {Tcl_GetChannelName} {testchannel} {
1.1983 + file delete $path(test1)
1.1984 + set f [open $path(test1) w]
1.1985 + set n [testchannel name $f]
1.1986 + close $f
1.1987 + string compare $n $f
1.1988 +} 0
1.1989 +
1.1990 +test io-24.1 {Tcl_GetChannelType} {testchannel} {
1.1991 + file delete $path(test1)
1.1992 + set f [open $path(test1) w]
1.1993 + set t [testchannel type $f]
1.1994 + close $f
1.1995 + string compare $t file
1.1996 +} 0
1.1997 +
1.1998 +test io-25.1 {Tcl_GetChannelHandle, input} {testchannel} {
1.1999 + set f [open $path(test1) w]
1.2000 + fconfigure $f -translation lf -eofchar {}
1.2001 + puts $f "1234567890\n098765432"
1.2002 + close $f
1.2003 + set f [open $path(test1) r]
1.2004 + gets $f
1.2005 + set l ""
1.2006 + lappend l [testchannel inputbuffered $f]
1.2007 + lappend l [tell $f]
1.2008 + close $f
1.2009 + set l
1.2010 +} {10 11}
1.2011 +test io-25.2 {Tcl_GetChannelHandle, output} {testchannel} {
1.2012 + file delete $path(test1)
1.2013 + set f [open $path(test1) w]
1.2014 + fconfigure $f -translation lf
1.2015 + puts $f hello
1.2016 + set l ""
1.2017 + lappend l [testchannel outputbuffered $f]
1.2018 + lappend l [tell $f]
1.2019 + flush $f
1.2020 + lappend l [testchannel outputbuffered $f]
1.2021 + lappend l [tell $f]
1.2022 + close $f
1.2023 + file delete $path(test1)
1.2024 + set l
1.2025 +} {6 6 0 6}
1.2026 +
1.2027 +test io-26.1 {Tcl_GetChannelInstanceData} {stdio openpipe} {
1.2028 + # "pid" command uses Tcl_GetChannelInstanceData
1.2029 + # Don't care what pid is (but must be a number), just want to exercise it.
1.2030 +
1.2031 + set f [open "|[list [interpreter] << exit]"]
1.2032 + expr [pid $f]
1.2033 + close $f
1.2034 +} {}
1.2035 +
1.2036 +# Test flushing. The functions tested here are FlushChannel.
1.2037 +
1.2038 +test io-27.1 {FlushChannel, no output buffered} {
1.2039 + file delete $path(test1)
1.2040 + set f [open $path(test1) w]
1.2041 + flush $f
1.2042 + set s [file size $path(test1)]
1.2043 + close $f
1.2044 + set s
1.2045 +} 0
1.2046 +test io-27.2 {FlushChannel, some output buffered} {
1.2047 + file delete $path(test1)
1.2048 + set f [open $path(test1) w]
1.2049 + fconfigure $f -translation lf -eofchar {}
1.2050 + set l ""
1.2051 + puts $f hello
1.2052 + lappend l [file size $path(test1)]
1.2053 + flush $f
1.2054 + lappend l [file size $path(test1)]
1.2055 + close $f
1.2056 + lappend l [file size $path(test1)]
1.2057 + set l
1.2058 +} {0 6 6}
1.2059 +test io-27.3 {FlushChannel, implicit flush on close} {
1.2060 + file delete $path(test1)
1.2061 + set f [open $path(test1) w]
1.2062 + fconfigure $f -translation lf -eofchar {}
1.2063 + set l ""
1.2064 + puts $f hello
1.2065 + lappend l [file size $path(test1)]
1.2066 + close $f
1.2067 + lappend l [file size $path(test1)]
1.2068 + set l
1.2069 +} {0 6}
1.2070 +test io-27.4 {FlushChannel, implicit flush when buffer fills} {
1.2071 + file delete $path(test1)
1.2072 + set f [open $path(test1) w]
1.2073 + fconfigure $f -translation lf -eofchar {}
1.2074 + fconfigure $f -buffersize 60
1.2075 + set l ""
1.2076 + lappend l [file size $path(test1)]
1.2077 + for {set i 0} {$i < 12} {incr i} {
1.2078 + puts $f hello
1.2079 + }
1.2080 + lappend l [file size $path(test1)]
1.2081 + flush $f
1.2082 + lappend l [file size $path(test1)]
1.2083 + close $f
1.2084 + set l
1.2085 +} {0 60 72}
1.2086 +test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \
1.2087 + {unixOrPc} {
1.2088 + file delete $path(test1)
1.2089 + set f [open $path(test1) w]
1.2090 + fconfigure $f -translation lf -buffersize 60 -eofchar {}
1.2091 + set l ""
1.2092 + lappend l [file size $path(test1)]
1.2093 + for {set i 0} {$i < 12} {incr i} {
1.2094 + puts $f hello
1.2095 + }
1.2096 + lappend l [file size $path(test1)]
1.2097 + close $f
1.2098 + lappend l [file size $path(test1)]
1.2099 + set l
1.2100 +} {0 60 72}
1.2101 +
1.2102 +set path(pipe) [makeFile {} pipe]
1.2103 +set path(output) [makeFile {} output]
1.2104 +
1.2105 +test io-27.6 {FlushChannel, async flushing, async close} \
1.2106 + {stdio asyncPipeClose openpipe} {
1.2107 + file delete $path(pipe)
1.2108 + file delete $path(output)
1.2109 + set f [open $path(pipe) w]
1.2110 + puts $f "set f \[[list open $path(output) w]]"
1.2111 + puts $f {
1.2112 + fconfigure $f -translation lf -buffering none -eofchar {}
1.2113 + while {![eof stdin]} {
1.2114 + after 20
1.2115 + puts -nonewline $f [read stdin 1024]
1.2116 + }
1.2117 + close $f
1.2118 + }
1.2119 + close $f
1.2120 + set x 01234567890123456789012345678901
1.2121 + for {set i 0} {$i < 11} {incr i} {
1.2122 + set x "$x$x"
1.2123 + }
1.2124 + set f [open $path(output) w]
1.2125 + close $f
1.2126 + set f [open "|[list [interpreter] $path(pipe)]" w]
1.2127 + fconfigure $f -blocking off
1.2128 + puts -nonewline $f $x
1.2129 + close $f
1.2130 + set counter 0
1.2131 + while {([file size $path(output)] < 65536) && ($counter < 1000)} {
1.2132 + incr counter
1.2133 + after 20
1.2134 + update
1.2135 + }
1.2136 + if {$counter == 1000} {
1.2137 + set result "file size only [file size $path(output)]"
1.2138 + } else {
1.2139 + set result ok
1.2140 + }
1.2141 +} ok
1.2142 +
1.2143 +# Tests closing a channel. The functions tested are CloseChannel and Tcl_Close.
1.2144 +
1.2145 +test io-28.1 {CloseChannel called when all references are dropped} {testchannel} {
1.2146 + file delete $path(test1)
1.2147 + set f [open $path(test1) w]
1.2148 + interp create x
1.2149 + interp share "" $f x
1.2150 + set l ""
1.2151 + lappend l [testchannel refcount $f]
1.2152 + x eval close $f
1.2153 + interp delete x
1.2154 + lappend l [testchannel refcount $f]
1.2155 + close $f
1.2156 + set l
1.2157 +} {2 1}
1.2158 +test io-28.2 {CloseChannel called when all references are dropped} {
1.2159 + file delete $path(test1)
1.2160 + set f [open $path(test1) w]
1.2161 + interp create x
1.2162 + interp share "" $f x
1.2163 + puts -nonewline $f abc
1.2164 + close $f
1.2165 + x eval puts $f def
1.2166 + x eval close $f
1.2167 + interp delete x
1.2168 + set f [open $path(test1) r]
1.2169 + set l [gets $f]
1.2170 + close $f
1.2171 + set l
1.2172 +} abcdef
1.2173 +test io-28.3 {CloseChannel, not called before output queue is empty} \
1.2174 + {stdio asyncPipeClose nonPortable openpipe} {
1.2175 + file delete $path(pipe)
1.2176 + file delete $path(output)
1.2177 + set f [open $path(pipe) w]
1.2178 + puts $f {
1.2179 +
1.2180 + # Need to not have eof char appended on close, because the other
1.2181 + # side of the pipe already closed, so that writing would cause an
1.2182 + # error "invalid file".
1.2183 +
1.2184 + fconfigure stdout -eofchar {}
1.2185 + fconfigure stderr -eofchar {}
1.2186 +
1.2187 + set f [open $path(output) w]
1.2188 + fconfigure $f -translation lf -buffering none
1.2189 + for {set x 0} {$x < 20} {incr x} {
1.2190 + after 20
1.2191 + puts -nonewline $f [read stdin 1024]
1.2192 + }
1.2193 + close $f
1.2194 + }
1.2195 + close $f
1.2196 + set x 01234567890123456789012345678901
1.2197 + for {set i 0} {$i < 11} {incr i} {
1.2198 + set x "$x$x"
1.2199 + }
1.2200 + set f [open $path(output) w]
1.2201 + close $f
1.2202 + set f [open "|[list [interpreter] pipe]" r+]
1.2203 + fconfigure $f -blocking off -eofchar {}
1.2204 +
1.2205 + puts -nonewline $f $x
1.2206 + close $f
1.2207 + set counter 0
1.2208 + while {([file size $path(output)] < 20480) && ($counter < 1000)} {
1.2209 + incr counter
1.2210 + after 20
1.2211 + update
1.2212 + }
1.2213 + if {$counter == 1000} {
1.2214 + set result probably_broken
1.2215 + } else {
1.2216 + set result ok
1.2217 + }
1.2218 +} ok
1.2219 +test io-28.4 {Tcl_Close} {testchannel} {
1.2220 + file delete $path(test1)
1.2221 + set l ""
1.2222 + lappend l [lsort [testchannel open]]
1.2223 + set f [open $path(test1) w]
1.2224 + lappend l [lsort [testchannel open]]
1.2225 + close $f
1.2226 + lappend l [lsort [testchannel open]]
1.2227 + set x [list $consoleFileNames \
1.2228 + [lsort [eval list $consoleFileNames $f]] \
1.2229 + $consoleFileNames]
1.2230 + string compare $l $x
1.2231 +} 0
1.2232 +test io-28.5 {Tcl_Close vs standard handles} {stdio unixOnly testchannel openpipe} {
1.2233 + file delete $path(script)
1.2234 + set f [open $path(script) w]
1.2235 + puts $f {
1.2236 + close stdin
1.2237 + puts [testchannel open]
1.2238 + }
1.2239 + close $f
1.2240 + set f [open "|[list [interpreter] $path(script)]" r]
1.2241 + set l [gets $f]
1.2242 + close $f
1.2243 + set l
1.2244 +} {file1 file2}
1.2245 +
1.2246 +test io-29.1 {Tcl_WriteChars, channel not writable} {
1.2247 + list [catch {puts stdin hello} msg] $msg
1.2248 +} {1 {channel "stdin" wasn't opened for writing}}
1.2249 +test io-29.2 {Tcl_WriteChars, empty string} {
1.2250 + file delete $path(test1)
1.2251 + set f [open $path(test1) w]
1.2252 + fconfigure $f -eofchar {}
1.2253 + puts -nonewline $f ""
1.2254 + close $f
1.2255 + file size $path(test1)
1.2256 +} 0
1.2257 +test io-29.3 {Tcl_WriteChars, nonempty string} {
1.2258 + file delete $path(test1)
1.2259 + set f [open $path(test1) w]
1.2260 + fconfigure $f -eofchar {}
1.2261 + puts -nonewline $f hello
1.2262 + close $f
1.2263 + file size $path(test1)
1.2264 +} 5
1.2265 +test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} {testchannel} {
1.2266 + file delete $path(test1)
1.2267 + set f [open $path(test1) w]
1.2268 + fconfigure $f -translation lf -buffering full -eofchar {}
1.2269 + puts $f hello
1.2270 + set l ""
1.2271 + lappend l [testchannel outputbuffered $f]
1.2272 + lappend l [file size $path(test1)]
1.2273 + flush $f
1.2274 + lappend l [testchannel outputbuffered $f]
1.2275 + lappend l [file size $path(test1)]
1.2276 + close $f
1.2277 + set l
1.2278 +} {6 0 0 6}
1.2279 +test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} {testchannel} {
1.2280 + file delete $path(test1)
1.2281 + set f [open $path(test1) w]
1.2282 + fconfigure $f -translation lf -buffering line -eofchar {}
1.2283 + puts -nonewline $f hello
1.2284 + set l ""
1.2285 + lappend l [testchannel outputbuffered $f]
1.2286 + lappend l [file size $path(test1)]
1.2287 + puts $f hello
1.2288 + lappend l [testchannel outputbuffered $f]
1.2289 + lappend l [file size $path(test1)]
1.2290 + close $f
1.2291 + set l
1.2292 +} {5 0 0 11}
1.2293 +test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} {testchannel} {
1.2294 + file delete $path(test1)
1.2295 + set f [open $path(test1) w]
1.2296 + fconfigure $f -translation lf -buffering none -eofchar {}
1.2297 + puts -nonewline $f hello
1.2298 + set l ""
1.2299 + lappend l [testchannel outputbuffered $f]
1.2300 + lappend l [file size $path(test1)]
1.2301 + puts $f hello
1.2302 + lappend l [testchannel outputbuffered $f]
1.2303 + lappend l [file size $path(test1)]
1.2304 + close $f
1.2305 + set l
1.2306 +} {0 5 0 11}
1.2307 +
1.2308 +test io-29.7 {Tcl_Flush, full buffering} {testchannel} {
1.2309 + file delete $path(test1)
1.2310 + set f [open $path(test1) w]
1.2311 + fconfigure $f -translation lf -buffering full -eofchar {}
1.2312 + puts -nonewline $f hello
1.2313 + set l ""
1.2314 + lappend l [testchannel outputbuffered $f]
1.2315 + lappend l [file size $path(test1)]
1.2316 + puts $f hello
1.2317 + lappend l [testchannel outputbuffered $f]
1.2318 + lappend l [file size $path(test1)]
1.2319 + flush $f
1.2320 + lappend l [testchannel outputbuffered $f]
1.2321 + lappend l [file size $path(test1)]
1.2322 + close $f
1.2323 + set l
1.2324 +} {5 0 11 0 0 11}
1.2325 +test io-29.8 {Tcl_Flush, full buffering} {testchannel} {
1.2326 + file delete $path(test1)
1.2327 + set f [open $path(test1) w]
1.2328 + fconfigure $f -translation lf -buffering line
1.2329 + puts -nonewline $f hello
1.2330 + set l ""
1.2331 + lappend l [testchannel outputbuffered $f]
1.2332 + lappend l [file size $path(test1)]
1.2333 + flush $f
1.2334 + lappend l [testchannel outputbuffered $f]
1.2335 + lappend l [file size $path(test1)]
1.2336 + puts $f hello
1.2337 + lappend l [testchannel outputbuffered $f]
1.2338 + lappend l [file size $path(test1)]
1.2339 + flush $f
1.2340 + lappend l [testchannel outputbuffered $f]
1.2341 + lappend l [file size $path(test1)]
1.2342 + close $f
1.2343 + set l
1.2344 +} {5 0 0 5 0 11 0 11}
1.2345 +test io-29.9 {Tcl_Flush, channel not writable} {
1.2346 + list [catch {flush stdin} msg] $msg
1.2347 +} {1 {channel "stdin" wasn't opened for writing}}
1.2348 +test io-29.10 {Tcl_WriteChars, looping and buffering} {
1.2349 + file delete $path(test1)
1.2350 + set f1 [open $path(test1) w]
1.2351 + fconfigure $f1 -translation lf -eofchar {}
1.2352 + set f2 [open $path(longfile) r]
1.2353 + for {set x 0} {$x < 10} {incr x} {
1.2354 + puts $f1 [gets $f2]
1.2355 + }
1.2356 + close $f2
1.2357 + close $f1
1.2358 + file size $path(test1)
1.2359 +} 387
1.2360 +test io-29.11 {Tcl_WriteChars, no newline, implicit flush} {
1.2361 + file delete $path(test1)
1.2362 + set f1 [open $path(test1) w]
1.2363 + fconfigure $f1 -eofchar {}
1.2364 + set f2 [open $path(longfile) r]
1.2365 + for {set x 0} {$x < 10} {incr x} {
1.2366 + puts -nonewline $f1 [gets $f2]
1.2367 + }
1.2368 + close $f1
1.2369 + close $f2
1.2370 + file size $path(test1)
1.2371 +} 377
1.2372 +test io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} {
1.2373 + file delete $path(test1)
1.2374 + file delete $path(pipe)
1.2375 + set f1 [open $path(pipe) w]
1.2376 + puts $f1 "set f1 \[[list open $path(longfile) r]]"
1.2377 + puts $f1 {
1.2378 + for {set x 0} {$x < 10} {incr x} {
1.2379 + puts [gets $f1]
1.2380 + }
1.2381 + }
1.2382 + close $f1
1.2383 + set f1 [open "|[list [interpreter] $path(pipe)]" r]
1.2384 + set f2 [open $path(longfile) r]
1.2385 + set y ok
1.2386 + for {set x 0} {$x < 10} {incr x} {
1.2387 + set l1 [gets $f1]
1.2388 + set l2 [gets $f2]
1.2389 + if {"$l1" != "$l2"} {
1.2390 + set y broken
1.2391 + }
1.2392 + }
1.2393 + close $f1
1.2394 + close $f2
1.2395 + set y
1.2396 +} ok
1.2397 +test io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio openpipe} {
1.2398 + file delete $path(test1)
1.2399 + file delete $path(pipe)
1.2400 + set f1 [open $path(pipe) w]
1.2401 + puts $f1 {
1.2402 + puts [gets stdin]
1.2403 + puts [gets stdin]
1.2404 + }
1.2405 + close $f1
1.2406 + set y ok
1.2407 + set f1 [open "|[list [interpreter] $path(pipe)]" r+]
1.2408 + fconfigure $f1 -buffering line
1.2409 + set f2 [open $path(longfile) r]
1.2410 + set line [gets $f2]
1.2411 + puts $f1 $line
1.2412 + set backline [gets $f1]
1.2413 + if {"$line" != "$backline"} {
1.2414 + set y broken
1.2415 + }
1.2416 + set line [gets $f2]
1.2417 + puts $f1 $line
1.2418 + set backline [gets $f1]
1.2419 + if {"$line" != "$backline"} {
1.2420 + set y broken
1.2421 + }
1.2422 + close $f1
1.2423 + close $f2
1.2424 + set y
1.2425 +} ok
1.2426 +test io-29.14 {Tcl_WriteChars, buffering and implicit flush at close} {
1.2427 + file delete $path(test3)
1.2428 + set f [open $path(test3) w]
1.2429 + puts -nonewline $f "Text1"
1.2430 + puts -nonewline $f " Text 2"
1.2431 + puts $f " Text 3"
1.2432 + close $f
1.2433 + set f [open $path(test3) r]
1.2434 + set x [gets $f]
1.2435 + close $f
1.2436 + set x
1.2437 +} {Text1 Text 2 Text 3}
1.2438 +test io-29.15 {Tcl_Flush, channel not open for writing} {
1.2439 + file delete $path(test1)
1.2440 + set fd [open $path(test1) w]
1.2441 + close $fd
1.2442 + set fd [open $path(test1) r]
1.2443 + set x [list [catch {flush $fd} msg] $msg]
1.2444 + close $fd
1.2445 + string compare $x \
1.2446 + [list 1 "channel \"$fd\" wasn't opened for writing"]
1.2447 +} 0
1.2448 +test io-29.16 {Tcl_Flush on pipe opened only for reading} {stdio openpipe} {
1.2449 + set fd [open "|[list [interpreter] cat longfile]" r]
1.2450 + set x [list [catch {flush $fd} msg] $msg]
1.2451 + catch {close $fd}
1.2452 + string compare $x \
1.2453 + [list 1 "channel \"$fd\" wasn't opened for writing"]
1.2454 +} 0
1.2455 +test io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} {
1.2456 + file delete $path(test1)
1.2457 + set f1 [open $path(test1) w]
1.2458 + fconfigure $f1 -translation lf
1.2459 + puts $f1 hello
1.2460 + puts $f1 hello
1.2461 + puts $f1 hello
1.2462 + flush $f1
1.2463 + set x [file size $path(test1)]
1.2464 + close $f1
1.2465 + set x
1.2466 +} 18
1.2467 +test io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} {
1.2468 + file delete $path(test1)
1.2469 + set x ""
1.2470 + set f1 [open $path(test1) w]
1.2471 + fconfigure $f1 -translation lf
1.2472 + puts $f1 hello
1.2473 + puts $f1 hello
1.2474 + puts $f1 hello
1.2475 + flush $f1
1.2476 + lappend x [file size $path(test1)]
1.2477 + puts $f1 hello
1.2478 + flush $f1
1.2479 + lappend x [file size $path(test1)]
1.2480 + puts $f1 hello
1.2481 + flush $f1
1.2482 + lappend x [file size $path(test1)]
1.2483 + close $f1
1.2484 + set x
1.2485 +} {18 24 30}
1.2486 +test io-29.19 {Explicit and implicit flushes} {
1.2487 + file delete $path(test1)
1.2488 + set f1 [open $path(test1) w]
1.2489 + fconfigure $f1 -translation lf -eofchar {}
1.2490 + set x ""
1.2491 + puts $f1 hello
1.2492 + puts $f1 hello
1.2493 + puts $f1 hello
1.2494 + flush $f1
1.2495 + lappend x [file size $path(test1)]
1.2496 + puts $f1 hello
1.2497 + flush $f1
1.2498 + lappend x [file size $path(test1)]
1.2499 + puts $f1 hello
1.2500 + close $f1
1.2501 + lappend x [file size $path(test1)]
1.2502 + set x
1.2503 +} {18 24 30}
1.2504 +test io-29.20 {Implicit flush when buffer is full} {
1.2505 + file delete $path(test1)
1.2506 + set f1 [open $path(test1) w]
1.2507 + fconfigure $f1 -translation lf -eofchar {}
1.2508 + set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
1.2509 + for {set x 0} {$x < 100} {incr x} {
1.2510 + puts $f1 $line
1.2511 + }
1.2512 + set z ""
1.2513 + lappend z [file size $path(test1)]
1.2514 + for {set x 0} {$x < 100} {incr x} {
1.2515 + puts $f1 $line
1.2516 + }
1.2517 + lappend z [file size $path(test1)]
1.2518 + close $f1
1.2519 + lappend z [file size $path(test1)]
1.2520 + set z
1.2521 +} {4096 12288 12600}
1.2522 +test io-29.21 {Tcl_Flush to pipe} {stdio openpipe} {
1.2523 + file delete $path(pipe)
1.2524 + set f1 [open $path(pipe) w]
1.2525 + puts $f1 {set x [read stdin 6]}
1.2526 + puts $f1 {set cnt [string length $x]}
1.2527 + puts $f1 {puts "read $cnt characters"}
1.2528 + close $f1
1.2529 + set f1 [open "|[list [interpreter] $path(pipe)]" r+]
1.2530 + puts $f1 hello
1.2531 + flush $f1
1.2532 + set x [gets $f1]
1.2533 + catch {close $f1}
1.2534 + set x
1.2535 +} "read 6 characters"
1.2536 +test io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} {
1.2537 + file delete $path(pipe)
1.2538 + set f1 [open $path(pipe) w]
1.2539 + puts $f1 {
1.2540 + fconfigure stdout -buffering full
1.2541 + puts hello
1.2542 + puts hello
1.2543 + flush stdout
1.2544 + gets stdin
1.2545 + puts bye
1.2546 + flush stdout
1.2547 + }
1.2548 + close $f1
1.2549 + set f1 [open "|[list [interpreter] $path(pipe)]" r+]
1.2550 + set x ""
1.2551 + lappend x [gets $f1]
1.2552 + lappend x [gets $f1]
1.2553 + puts $f1 hello
1.2554 + flush $f1
1.2555 + lappend x [gets $f1]
1.2556 + close $f1
1.2557 + set x
1.2558 +} {hello hello bye}
1.2559 +test io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio openpipe} {
1.2560 + file delete $path(pipe)
1.2561 + set f1 [open $path(pipe) w]
1.2562 + puts $f1 {
1.2563 + puts hello
1.2564 + puts hello
1.2565 + gets stdin
1.2566 + puts bye
1.2567 + }
1.2568 + close $f1
1.2569 + set f1 [open "|[list [interpreter] $path(pipe)]" r+]
1.2570 + set x ""
1.2571 + lappend x [gets $f1]
1.2572 + lappend x [gets $f1]
1.2573 + puts $f1 hello
1.2574 + flush $f1
1.2575 + lappend x [gets $f1]
1.2576 + close $f1
1.2577 + set x
1.2578 +} {hello hello bye}
1.2579 +test io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} {
1.2580 + set f [open $path(test3) w]
1.2581 + puts $f "Line 1"
1.2582 + puts $f "Line 2"
1.2583 + set f2 [open $path(test3)]
1.2584 + set x {}
1.2585 + lappend x [read -nonewline $f2]
1.2586 + close $f2
1.2587 + flush $f
1.2588 + set f2 [open $path(test3)]
1.2589 + lappend x [read -nonewline $f2]
1.2590 + close $f2
1.2591 + close $f
1.2592 + set x
1.2593 +} "{} {Line 1\nLine 2}"
1.2594 +test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpipe fileevent} {
1.2595 + file delete $path(test3)
1.2596 + set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w]
1.2597 + puts $f "Line 1"
1.2598 + puts $f "Line 2"
1.2599 + close $f
1.2600 + after 100
1.2601 + set f [open $path(test3) r]
1.2602 + set x [read $f]
1.2603 + close $f
1.2604 + set x
1.2605 +} "Line 1\nLine 2\n"
1.2606 +test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs openpipe} {
1.2607 + set f [open "|[list cat -u]" r+]
1.2608 + puts $f "Line1"
1.2609 + flush $f
1.2610 + set x [gets $f]
1.2611 + close $f
1.2612 + set x
1.2613 +} {Line1}
1.2614 +test io-29.27 {Tcl_Flush on closed pipeline} {stdio openpipe} {
1.2615 + file delete $path(pipe)
1.2616 + set f [open $path(pipe) w]
1.2617 + puts $f {exit}
1.2618 + close $f
1.2619 + set f [open "|[list [interpreter] $path(pipe)]" r+]
1.2620 + gets $f
1.2621 + puts $f output
1.2622 + after 50
1.2623 + #
1.2624 + # The flush below will get a SIGPIPE. This is an expected part of
1.2625 + # test and indicates that the test operates correctly. If you run
1.2626 + # this test under a debugger, the signal will by intercepted unless
1.2627 + # you disable the debugger's signal interception.
1.2628 + #
1.2629 + if {[catch {flush $f} msg]} {
1.2630 + set x [list 1 $msg $errorCode]
1.2631 + catch {close $f}
1.2632 + } else {
1.2633 + if {[catch {close $f} msg]} {
1.2634 + set x [list 1 $msg $errorCode]
1.2635 + } else {
1.2636 + set x {this was supposed to fail and did not}
1.2637 + }
1.2638 + }
1.2639 + regsub {".*":} $x {"":} x
1.2640 + string tolower $x
1.2641 +} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}}
1.2642 +test io-29.28 {Tcl_WriteChars, lf mode} {
1.2643 + file delete $path(test1)
1.2644 + set f [open $path(test1) w]
1.2645 + fconfigure $f -translation lf -eofchar {}
1.2646 + puts $f hello\nthere\nand\nhere
1.2647 + flush $f
1.2648 + set s [file size $path(test1)]
1.2649 + close $f
1.2650 + set s
1.2651 +} 21
1.2652 +test io-29.29 {Tcl_WriteChars, cr mode} {
1.2653 + file delete $path(test1)
1.2654 + set f [open $path(test1) w]
1.2655 + fconfigure $f -translation cr -eofchar {}
1.2656 + puts $f hello\nthere\nand\nhere
1.2657 + close $f
1.2658 + file size $path(test1)
1.2659 +} 21
1.2660 +test io-29.30 {Tcl_WriteChars, crlf mode} {
1.2661 + file delete $path(test1)
1.2662 + set f [open $path(test1) w]
1.2663 + fconfigure $f -translation crlf -eofchar {}
1.2664 + puts $f hello\nthere\nand\nhere
1.2665 + close $f
1.2666 + file size $path(test1)
1.2667 +} 25
1.2668 +test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} {
1.2669 + file delete $path(pipe)
1.2670 + file delete $path(output)
1.2671 + set f [open $path(pipe) w]
1.2672 + puts $f "set f \[[list open $path(output) w]]"
1.2673 + puts $f {fconfigure $f -translation lf}
1.2674 + set x [list while {![eof stdin]}]
1.2675 + set x "$x {"
1.2676 + puts $f $x
1.2677 + puts $f { puts -nonewline $f [read stdin 4096]}
1.2678 + puts $f { flush $f}
1.2679 + puts $f "}"
1.2680 + puts $f {close $f}
1.2681 + close $f
1.2682 + set x 01234567890123456789012345678901
1.2683 + for {set i 0} {$i < 11} {incr i} {
1.2684 + set x "$x$x"
1.2685 + }
1.2686 + set f [open $path(output) w]
1.2687 + close $f
1.2688 + set f [open "|[list [interpreter] $path(pipe)]" r+]
1.2689 + fconfigure $f -blocking off
1.2690 + puts -nonewline $f $x
1.2691 + close $f
1.2692 + set counter 0
1.2693 + while {([file size $path(output)] < 65536) && ($counter < 1000)} {
1.2694 + incr counter
1.2695 + after 5
1.2696 + update
1.2697 + }
1.2698 + if {$counter == 1000} {
1.2699 + set result "file size only [file size $path(output)]"
1.2700 + } else {
1.2701 + set result ok
1.2702 + }
1.2703 +} ok
1.2704 +test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
1.2705 + {stdio asyncPipeClose openpipe} {
1.2706 + file delete $path(pipe)
1.2707 + file delete $path(output)
1.2708 + set f [open $path(pipe) w]
1.2709 + puts $f "set f \[[list open $path(output) w]]"
1.2710 + puts $f {fconfigure $f -translation lf}
1.2711 + set x [list while {![eof stdin]}]
1.2712 + set x "$x \{"
1.2713 + puts $f $x
1.2714 + puts $f { after 20}
1.2715 + puts $f { puts -nonewline $f [read stdin 1024]}
1.2716 + puts $f { flush $f}
1.2717 + puts $f "\}"
1.2718 + puts $f {close $f}
1.2719 + close $f
1.2720 + set x 01234567890123456789012345678901
1.2721 + for {set i 0} {$i < 11} {incr i} {
1.2722 + set x "$x$x"
1.2723 + }
1.2724 + set f [open $path(output) w]
1.2725 + close $f
1.2726 + set f [open "|[list [interpreter] $path(pipe)]" r+]
1.2727 + fconfigure $f -blocking off
1.2728 + puts -nonewline $f $x
1.2729 + close $f
1.2730 + set counter 0
1.2731 + while {([file size $path(output)] < 65536) && ($counter < 1000)} {
1.2732 + incr counter
1.2733 + after 20
1.2734 + update
1.2735 + }
1.2736 + if {$counter == 1000} {
1.2737 + set result "file size only [file size $path(output)]"
1.2738 + } else {
1.2739 + set result ok
1.2740 + }
1.2741 +} ok
1.2742 +test io-29.33 {Tcl_Flush, implicit flush on exit} {exec} {
1.2743 + set f [open $path(script) w]
1.2744 + puts $f "set f \[[list open $path(test1) w]]"
1.2745 + puts $f {fconfigure $f -translation lf
1.2746 + puts $f hello
1.2747 + puts $f bye
1.2748 + puts $f strange
1.2749 + }
1.2750 + close $f
1.2751 + exec [interpreter] $path(script)
1.2752 + set f [open $path(test1) r]
1.2753 + set r [read $f]
1.2754 + close $f
1.2755 + set r
1.2756 +} "hello\nbye\nstrange\n"
1.2757 +test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac fileevent} {
1.2758 + variable c 0
1.2759 + variable x running
1.2760 + set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
1.2761 + proc writelots {s l} {
1.2762 + for {set i 0} {$i < 2000} {incr i} {
1.2763 + puts $s $l
1.2764 + }
1.2765 + }
1.2766 + proc accept {s a p} {
1.2767 + variable x
1.2768 + fileevent $s readable [namespace code [list readit $s]]
1.2769 + fconfigure $s -blocking off
1.2770 + set x accepted
1.2771 + }
1.2772 + proc readit {s} {
1.2773 + variable c
1.2774 + variable x
1.2775 + set l [gets $s]
1.2776 +
1.2777 + if {[eof $s]} {
1.2778 + close $s
1.2779 + set x done
1.2780 + } elseif {([string length $l] > 0) || ![fblocked $s]} {
1.2781 + incr c
1.2782 + }
1.2783 + }
1.2784 + set ss [socket -server [namespace code accept] 0]
1.2785 + set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
1.2786 + vwait [namespace which -variable x]
1.2787 + fconfigure $cs -blocking off
1.2788 + writelots $cs $l
1.2789 + close $cs
1.2790 + close $ss
1.2791 + vwait [namespace which -variable x]
1.2792 + set c
1.2793 +} 2000
1.2794 +test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac fileevent} {
1.2795 + # On Mac, this test screws up sockets such that subsequent tests using port 2828
1.2796 + # either cause errors or panic().
1.2797 +
1.2798 + catch {interp delete x}
1.2799 + catch {interp delete y}
1.2800 + interp create x
1.2801 + interp create y
1.2802 + set s [socket -server [namespace code accept] 0]
1.2803 + proc accept {s a p} {
1.2804 + puts $s hello
1.2805 + close $s
1.2806 + }
1.2807 + set c [socket [info hostname] [lindex [fconfigure $s -sockname] 2]]
1.2808 + interp share {} $c x
1.2809 + interp share {} $c y
1.2810 + close $c
1.2811 + x eval {
1.2812 + proc readit {s} {
1.2813 + gets $s
1.2814 + if {[eof $s]} {
1.2815 + close $s
1.2816 + }
1.2817 + }
1.2818 + }
1.2819 + y eval {
1.2820 + proc readit {s} {
1.2821 + gets $s
1.2822 + if {[eof $s]} {
1.2823 + close $s
1.2824 + }
1.2825 + }
1.2826 + }
1.2827 + x eval "fileevent $c readable \{readit $c\}"
1.2828 + y eval "fileevent $c readable \{readit $c\}"
1.2829 + y eval [list close $c]
1.2830 + update
1.2831 + close $s
1.2832 + interp delete x
1.2833 + interp delete y
1.2834 +} ""
1.2835 +
1.2836 +# Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read.
1.2837 +
1.2838 +test io-30.1 {Tcl_Write lf, Tcl_Read lf} {
1.2839 + file delete $path(test1)
1.2840 + set f [open $path(test1) w]
1.2841 + fconfigure $f -translation lf
1.2842 + puts $f hello\nthere\nand\nhere
1.2843 + close $f
1.2844 + set f [open $path(test1) r]
1.2845 + fconfigure $f -translation lf
1.2846 + set x [read $f]
1.2847 + close $f
1.2848 + set x
1.2849 +} "hello\nthere\nand\nhere\n"
1.2850 +test io-30.2 {Tcl_Write lf, Tcl_Read cr} {
1.2851 + file delete $path(test1)
1.2852 + set f [open $path(test1) w]
1.2853 + fconfigure $f -translation lf
1.2854 + puts $f hello\nthere\nand\nhere
1.2855 + close $f
1.2856 + set f [open $path(test1) r]
1.2857 + fconfigure $f -translation cr
1.2858 + set x [read $f]
1.2859 + close $f
1.2860 + set x
1.2861 +} "hello\nthere\nand\nhere\n"
1.2862 +test io-30.3 {Tcl_Write lf, Tcl_Read crlf} {
1.2863 + file delete $path(test1)
1.2864 + set f [open $path(test1) w]
1.2865 + fconfigure $f -translation lf
1.2866 + puts $f hello\nthere\nand\nhere
1.2867 + close $f
1.2868 + set f [open $path(test1) r]
1.2869 + fconfigure $f -translation crlf
1.2870 + set x [read $f]
1.2871 + close $f
1.2872 + set x
1.2873 +} "hello\nthere\nand\nhere\n"
1.2874 +test io-30.4 {Tcl_Write cr, Tcl_Read cr} {
1.2875 + file delete $path(test1)
1.2876 + set f [open $path(test1) w]
1.2877 + fconfigure $f -translation cr
1.2878 + puts $f hello\nthere\nand\nhere
1.2879 + close $f
1.2880 + set f [open $path(test1) r]
1.2881 + fconfigure $f -translation cr
1.2882 + set x [read $f]
1.2883 + close $f
1.2884 + set x
1.2885 +} "hello\nthere\nand\nhere\n"
1.2886 +test io-30.5 {Tcl_Write cr, Tcl_Read lf} {
1.2887 + file delete $path(test1)
1.2888 + set f [open $path(test1) w]
1.2889 + fconfigure $f -translation cr
1.2890 + puts $f hello\nthere\nand\nhere
1.2891 + close $f
1.2892 + set f [open $path(test1) r]
1.2893 + fconfigure $f -translation lf
1.2894 + set x [read $f]
1.2895 + close $f
1.2896 + set x
1.2897 +} "hello\rthere\rand\rhere\r"
1.2898 +test io-30.6 {Tcl_Write cr, Tcl_Read crlf} {
1.2899 + file delete $path(test1)
1.2900 + set f [open $path(test1) w]
1.2901 + fconfigure $f -translation cr
1.2902 + puts $f hello\nthere\nand\nhere
1.2903 + close $f
1.2904 + set f [open $path(test1) r]
1.2905 + fconfigure $f -translation crlf
1.2906 + set x [read $f]
1.2907 + close $f
1.2908 + set x
1.2909 +} "hello\rthere\rand\rhere\r"
1.2910 +test io-30.7 {Tcl_Write crlf, Tcl_Read crlf} {
1.2911 + file delete $path(test1)
1.2912 + set f [open $path(test1) w]
1.2913 + fconfigure $f -translation crlf
1.2914 + puts $f hello\nthere\nand\nhere
1.2915 + close $f
1.2916 + set f [open $path(test1) r]
1.2917 + fconfigure $f -translation crlf
1.2918 + set x [read $f]
1.2919 + close $f
1.2920 + set x
1.2921 +} "hello\nthere\nand\nhere\n"
1.2922 +test io-30.8 {Tcl_Write crlf, Tcl_Read lf} {
1.2923 + file delete $path(test1)
1.2924 + set f [open $path(test1) w]
1.2925 + fconfigure $f -translation crlf
1.2926 + puts $f hello\nthere\nand\nhere
1.2927 + close $f
1.2928 + set f [open $path(test1) r]
1.2929 + fconfigure $f -translation lf
1.2930 + set x [read $f]
1.2931 + close $f
1.2932 + set x
1.2933 +} "hello\r\nthere\r\nand\r\nhere\r\n"
1.2934 +test io-30.9 {Tcl_Write crlf, Tcl_Read cr} {
1.2935 + file delete $path(test1)
1.2936 + set f [open $path(test1) w]
1.2937 + fconfigure $f -translation crlf
1.2938 + puts $f hello\nthere\nand\nhere
1.2939 + close $f
1.2940 + set f [open $path(test1) r]
1.2941 + fconfigure $f -translation cr
1.2942 + set x [read $f]
1.2943 + close $f
1.2944 + set x
1.2945 +} "hello\n\nthere\n\nand\n\nhere\n\n"
1.2946 +test io-30.10 {Tcl_Write lf, Tcl_Read auto} {
1.2947 + file delete $path(test1)
1.2948 + set f [open $path(test1) w]
1.2949 + fconfigure $f -translation lf
1.2950 + puts $f hello\nthere\nand\nhere
1.2951 + close $f
1.2952 + set f [open $path(test1) r]
1.2953 + set c [read $f]
1.2954 + set x [fconfigure $f -translation]
1.2955 + close $f
1.2956 + list $c $x
1.2957 +} {{hello
1.2958 +there
1.2959 +and
1.2960 +here
1.2961 +} auto}
1.2962 +test io-30.11 {Tcl_Write cr, Tcl_Read auto} {
1.2963 + file delete $path(test1)
1.2964 + set f [open $path(test1) w]
1.2965 + fconfigure $f -translation cr
1.2966 + puts $f hello\nthere\nand\nhere
1.2967 + close $f
1.2968 + set f [open $path(test1) r]
1.2969 + set c [read $f]
1.2970 + set x [fconfigure $f -translation]
1.2971 + close $f
1.2972 + list $c $x
1.2973 +} {{hello
1.2974 +there
1.2975 +and
1.2976 +here
1.2977 +} auto}
1.2978 +test io-30.12 {Tcl_Write crlf, Tcl_Read auto} {
1.2979 + file delete $path(test1)
1.2980 + set f [open $path(test1) w]
1.2981 + fconfigure $f -translation crlf
1.2982 + puts $f hello\nthere\nand\nhere
1.2983 + close $f
1.2984 + set f [open $path(test1) r]
1.2985 + set c [read $f]
1.2986 + set x [fconfigure $f -translation]
1.2987 + close $f
1.2988 + list $c $x
1.2989 +} {{hello
1.2990 +there
1.2991 +and
1.2992 +here
1.2993 +} auto}
1.2994 +
1.2995 +test io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} {
1.2996 + file delete $path(test1)
1.2997 + set f [open $path(test1) w]
1.2998 + fconfigure $f -translation crlf
1.2999 + set line "123456789ABCDE" ;# 14 char plus crlf
1.3000 + puts -nonewline $f x ;# shift crlf across block boundary
1.3001 + for {set i 0} {$i < 700} {incr i} {
1.3002 + puts $f $line
1.3003 + }
1.3004 + close $f
1.3005 + set f [open $path(test1) r]
1.3006 + fconfigure $f -translation auto
1.3007 + set c [read $f]
1.3008 + close $f
1.3009 + string length $c
1.3010 +} [expr 700*15+1]
1.3011 +
1.3012 +test io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} {
1.3013 + file delete $path(test1)
1.3014 + set f [open $path(test1) w]
1.3015 + fconfigure $f -translation crlf
1.3016 + set line "123456789ABCDE" ;# 14 char plus crlf
1.3017 + puts -nonewline $f x ;# shift crlf across block boundary
1.3018 + for {set i 0} {$i < 700} {incr i} {
1.3019 + puts $f $line
1.3020 + }
1.3021 + close $f
1.3022 + set f [open $path(test1) r]
1.3023 + fconfigure $f -translation crlf
1.3024 + set c [read $f]
1.3025 + close $f
1.3026 + string length $c
1.3027 +} [expr 700*15+1]
1.3028 +
1.3029 +test io-30.15 {Tcl_Write mixed, Tcl_Read auto} {
1.3030 + file delete $path(test1)
1.3031 + set f [open $path(test1) w]
1.3032 + fconfigure $f -translation lf
1.3033 + puts $f hello\nthere\nand\rhere
1.3034 + close $f
1.3035 + set f [open $path(test1) r]
1.3036 + fconfigure $f -translation auto
1.3037 + set c [read $f]
1.3038 + close $f
1.3039 + set c
1.3040 +} {hello
1.3041 +there
1.3042 +and
1.3043 +here
1.3044 +}
1.3045 +test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} {
1.3046 + file delete $path(test1)
1.3047 + set f [open $path(test1) w]
1.3048 + fconfigure $f -translation lf
1.3049 + puts -nonewline $f hello\nthere\nand\rhere\n\x1a
1.3050 + close $f
1.3051 + set f [open $path(test1) r]
1.3052 + fconfigure $f -eofchar \x1a -translation auto
1.3053 + set c [read $f]
1.3054 + close $f
1.3055 + set c
1.3056 +} {hello
1.3057 +there
1.3058 +and
1.3059 +here
1.3060 +}
1.3061 +test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {pcOnly} {
1.3062 + file delete $path(test1)
1.3063 + set f [open $path(test1) w]
1.3064 + fconfigure $f -eofchar \x1a -translation lf
1.3065 + puts $f hello\nthere\nand\rhere
1.3066 + close $f
1.3067 + set f [open $path(test1) r]
1.3068 + fconfigure $f -eofchar \x1a -translation auto
1.3069 + set c [read $f]
1.3070 + close $f
1.3071 + set c
1.3072 +} {hello
1.3073 +there
1.3074 +and
1.3075 +here
1.3076 +}
1.3077 +test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} {
1.3078 + file delete $path(test1)
1.3079 + set f [open $path(test1) w]
1.3080 + fconfigure $f -translation lf
1.3081 + set s [format "abc\ndef\n%cghi\nqrs" 26]
1.3082 + puts $f $s
1.3083 + close $f
1.3084 + set f [open $path(test1) r]
1.3085 + fconfigure $f -eofchar \x1a -translation auto
1.3086 + set l ""
1.3087 + lappend l [gets $f]
1.3088 + lappend l [gets $f]
1.3089 + lappend l [eof $f]
1.3090 + lappend l [gets $f]
1.3091 + lappend l [eof $f]
1.3092 + lappend l [gets $f]
1.3093 + lappend l [eof $f]
1.3094 + close $f
1.3095 + set l
1.3096 +} {abc def 0 {} 1 {} 1}
1.3097 +test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} {
1.3098 + file delete $path(test1)
1.3099 + set f [open $path(test1) w]
1.3100 + fconfigure $f -translation lf
1.3101 + set s [format "abc\ndef\n%cghi\nqrs" 26]
1.3102 + puts $f $s
1.3103 + close $f
1.3104 + set f [open $path(test1) r]
1.3105 + fconfigure $f -eofchar \x1a -translation auto
1.3106 + set l ""
1.3107 + lappend l [gets $f]
1.3108 + lappend l [gets $f]
1.3109 + lappend l [eof $f]
1.3110 + lappend l [gets $f]
1.3111 + lappend l [eof $f]
1.3112 + lappend l [gets $f]
1.3113 + lappend l [eof $f]
1.3114 + close $f
1.3115 + set l
1.3116 +} {abc def 0 {} 1 {} 1}
1.3117 +test io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} {
1.3118 + file delete $path(test1)
1.3119 + set f [open $path(test1) w]
1.3120 + fconfigure $f -translation lf -eofchar {}
1.3121 + set s [format "abc\ndef\n%cghi\nqrs" 26]
1.3122 + puts $f $s
1.3123 + close $f
1.3124 + set f [open $path(test1) r]
1.3125 + fconfigure $f -translation lf -eofchar {}
1.3126 + set l ""
1.3127 + lappend l [gets $f]
1.3128 + lappend l [gets $f]
1.3129 + lappend l [eof $f]
1.3130 + lappend l [gets $f]
1.3131 + lappend l [eof $f]
1.3132 + lappend l [gets $f]
1.3133 + lappend l [eof $f]
1.3134 + lappend l [gets $f]
1.3135 + lappend l [eof $f]
1.3136 + close $f
1.3137 + set l
1.3138 +} "abc def 0 \x1aghi 0 qrs 0 {} 1"
1.3139 +test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} {
1.3140 + file delete $path(test1)
1.3141 + set f [open $path(test1) w]
1.3142 + fconfigure $f -translation lf -eofchar {}
1.3143 + set s [format "abc\ndef\n%cghi\nqrs" 26]
1.3144 + puts $f $s
1.3145 + close $f
1.3146 + set f [open $path(test1) r]
1.3147 + fconfigure $f -translation cr -eofchar {}
1.3148 + set l ""
1.3149 + set x [gets $f]
1.3150 + lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"]
1.3151 + lappend l [eof $f]
1.3152 + lappend l [gets $f]
1.3153 + lappend l [eof $f]
1.3154 + close $f
1.3155 + set l
1.3156 +} {0 1 {} 1}
1.3157 +test io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} {
1.3158 + file delete $path(test1)
1.3159 + set f [open $path(test1) w]
1.3160 + fconfigure $f -translation lf -eofchar {}
1.3161 + set s [format "abc\ndef\n%cghi\nqrs" 26]
1.3162 + puts $f $s
1.3163 + close $f
1.3164 + set f [open $path(test1) r]
1.3165 + fconfigure $f -translation crlf -eofchar {}
1.3166 + set l ""
1.3167 + set x [gets $f]
1.3168 + lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"]
1.3169 + lappend l [eof $f]
1.3170 + lappend l [gets $f]
1.3171 + lappend l [eof $f]
1.3172 + close $f
1.3173 + set l
1.3174 +} {0 1 {} 1}
1.3175 +test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} {
1.3176 + file delete $path(test1)
1.3177 + set f [open $path(test1) w]
1.3178 + fconfigure $f -translation lf
1.3179 + set c [format abc\ndef\n%cqrs\ntuv 26]
1.3180 + puts $f $c
1.3181 + close $f
1.3182 + set f [open $path(test1) r]
1.3183 + fconfigure $f -translation auto -eofchar \x1a
1.3184 + set c [string length [read $f]]
1.3185 + set e [eof $f]
1.3186 + close $f
1.3187 + list $c $e
1.3188 +} {8 1}
1.3189 +test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} {
1.3190 + file delete $path(test1)
1.3191 + set f [open $path(test1) w]
1.3192 + fconfigure $f -translation lf
1.3193 + set c [format abc\ndef\n%cqrs\ntuv 26]
1.3194 + puts $f $c
1.3195 + close $f
1.3196 + set f [open $path(test1) r]
1.3197 + fconfigure $f -translation lf -eofchar \x1a
1.3198 + set c [string length [read $f]]
1.3199 + set e [eof $f]
1.3200 + close $f
1.3201 + list $c $e
1.3202 +} {8 1}
1.3203 +test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} {
1.3204 + file delete $path(test1)
1.3205 + set f [open $path(test1) w]
1.3206 + fconfigure $f -translation cr
1.3207 + set c [format abc\ndef\n%cqrs\ntuv 26]
1.3208 + puts $f $c
1.3209 + close $f
1.3210 + set f [open $path(test1) r]
1.3211 + fconfigure $f -translation auto -eofchar \x1a
1.3212 + set c [string length [read $f]]
1.3213 + set e [eof $f]
1.3214 + close $f
1.3215 + list $c $e
1.3216 +} {8 1}
1.3217 +test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} {
1.3218 + file delete $path(test1)
1.3219 + set f [open $path(test1) w]
1.3220 + fconfigure $f -translation cr
1.3221 + set c [format abc\ndef\n%cqrs\ntuv 26]
1.3222 + puts $f $c
1.3223 + close $f
1.3224 + set f [open $path(test1) r]
1.3225 + fconfigure $f -translation cr -eofchar \x1a
1.3226 + set c [string length [read $f]]
1.3227 + set e [eof $f]
1.3228 + close $f
1.3229 + list $c $e
1.3230 +} {8 1}
1.3231 +test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} {
1.3232 + file delete $path(test1)
1.3233 + set f [open $path(test1) w]
1.3234 + fconfigure $f -translation crlf
1.3235 + set c [format abc\ndef\n%cqrs\ntuv 26]
1.3236 + puts $f $c
1.3237 + close $f
1.3238 + set f [open $path(test1) r]
1.3239 + fconfigure $f -translation auto -eofchar \x1a
1.3240 + set c [string length [read $f]]
1.3241 + set e [eof $f]
1.3242 + close $f
1.3243 + list $c $e
1.3244 +} {8 1}
1.3245 +test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} {
1.3246 + file delete $path(test1)
1.3247 + set f [open $path(test1) w]
1.3248 + fconfigure $f -translation crlf
1.3249 + set c [format abc\ndef\n%cqrs\ntuv 26]
1.3250 + puts $f $c
1.3251 + close $f
1.3252 + set f [open $path(test1) r]
1.3253 + fconfigure $f -translation crlf -eofchar \x1a
1.3254 + set c [string length [read $f]]
1.3255 + set e [eof $f]
1.3256 + close $f
1.3257 + list $c $e
1.3258 +} {8 1}
1.3259 +
1.3260 +# Test end of line translations. Functions tested are Tcl_Write and Tcl_Gets.
1.3261 +
1.3262 +test io-31.1 {Tcl_Write lf, Tcl_Gets auto} {
1.3263 + file delete $path(test1)
1.3264 + set f [open $path(test1) w]
1.3265 + fconfigure $f -translation lf
1.3266 + puts $f hello\nthere\nand\nhere
1.3267 + close $f
1.3268 + set f [open $path(test1) r]
1.3269 + set l ""
1.3270 + lappend l [gets $f]
1.3271 + lappend l [tell $f]
1.3272 + lappend l [fconfigure $f -translation]
1.3273 + lappend l [gets $f]
1.3274 + lappend l [tell $f]
1.3275 + lappend l [fconfigure $f -translation]
1.3276 + close $f
1.3277 + set l
1.3278 +} {hello 6 auto there 12 auto}
1.3279 +test io-31.2 {Tcl_Write cr, Tcl_Gets auto} {
1.3280 + file delete $path(test1)
1.3281 + set f [open $path(test1) w]
1.3282 + fconfigure $f -translation cr
1.3283 + puts $f hello\nthere\nand\nhere
1.3284 + close $f
1.3285 + set f [open $path(test1) r]
1.3286 + set l ""
1.3287 + lappend l [gets $f]
1.3288 + lappend l [tell $f]
1.3289 + lappend l [fconfigure $f -translation]
1.3290 + lappend l [gets $f]
1.3291 + lappend l [tell $f]
1.3292 + lappend l [fconfigure $f -translation]
1.3293 + close $f
1.3294 + set l
1.3295 +} {hello 6 auto there 12 auto}
1.3296 +test io-31.3 {Tcl_Write crlf, Tcl_Gets auto} {
1.3297 + file delete $path(test1)
1.3298 + set f [open $path(test1) w]
1.3299 + fconfigure $f -translation crlf
1.3300 + puts $f hello\nthere\nand\nhere
1.3301 + close $f
1.3302 + set f [open $path(test1) r]
1.3303 + set l ""
1.3304 + lappend l [gets $f]
1.3305 + lappend l [tell $f]
1.3306 + lappend l [fconfigure $f -translation]
1.3307 + lappend l [gets $f]
1.3308 + lappend l [tell $f]
1.3309 + lappend l [fconfigure $f -translation]
1.3310 + close $f
1.3311 + set l
1.3312 +} {hello 7 auto there 14 auto}
1.3313 +test io-31.4 {Tcl_Write lf, Tcl_Gets lf} {
1.3314 + file delete $path(test1)
1.3315 + set f [open $path(test1) w]
1.3316 + fconfigure $f -translation lf
1.3317 + puts $f hello\nthere\nand\nhere
1.3318 + close $f
1.3319 + set f [open $path(test1) r]
1.3320 + fconfigure $f -translation lf
1.3321 + set l ""
1.3322 + lappend l [gets $f]
1.3323 + lappend l [tell $f]
1.3324 + lappend l [fconfigure $f -translation]
1.3325 + lappend l [gets $f]
1.3326 + lappend l [tell $f]
1.3327 + lappend l [fconfigure $f -translation]
1.3328 + close $f
1.3329 + set l
1.3330 +} {hello 6 lf there 12 lf}
1.3331 +test io-31.5 {Tcl_Write lf, Tcl_Gets cr} {
1.3332 + file delete $path(test1)
1.3333 + set f [open $path(test1) w]
1.3334 + fconfigure $f -translation lf
1.3335 + puts $f hello\nthere\nand\nhere
1.3336 + close $f
1.3337 + set f [open $path(test1) r]
1.3338 + fconfigure $f -translation cr
1.3339 + set l ""
1.3340 + lappend l [string length [gets $f]]
1.3341 + lappend l [tell $f]
1.3342 + lappend l [fconfigure $f -translation]
1.3343 + lappend l [eof $f]
1.3344 + lappend l [gets $f]
1.3345 + lappend l [tell $f]
1.3346 + lappend l [fconfigure $f -translation]
1.3347 + lappend l [eof $f]
1.3348 + close $f
1.3349 + set l
1.3350 +} {21 21 cr 1 {} 21 cr 1}
1.3351 +test io-31.6 {Tcl_Write lf, Tcl_Gets crlf} {
1.3352 + file delete $path(test1)
1.3353 + set f [open $path(test1) w]
1.3354 + fconfigure $f -translation lf
1.3355 + puts $f hello\nthere\nand\nhere
1.3356 + close $f
1.3357 + set f [open $path(test1) r]
1.3358 + fconfigure $f -translation crlf
1.3359 + set l ""
1.3360 + lappend l [string length [gets $f]]
1.3361 + lappend l [tell $f]
1.3362 + lappend l [fconfigure $f -translation]
1.3363 + lappend l [eof $f]
1.3364 + lappend l [gets $f]
1.3365 + lappend l [tell $f]
1.3366 + lappend l [fconfigure $f -translation]
1.3367 + lappend l [eof $f]
1.3368 + close $f
1.3369 + set l
1.3370 +} {21 21 crlf 1 {} 21 crlf 1}
1.3371 +test io-31.7 {Tcl_Write cr, Tcl_Gets cr} {
1.3372 + file delete $path(test1)
1.3373 + set f [open $path(test1) w]
1.3374 + fconfigure $f -translation cr
1.3375 + puts $f hello\nthere\nand\nhere
1.3376 + close $f
1.3377 + set f [open $path(test1) r]
1.3378 + fconfigure $f -translation cr
1.3379 + set l ""
1.3380 + lappend l [gets $f]
1.3381 + lappend l [tell $f]
1.3382 + lappend l [fconfigure $f -translation]
1.3383 + lappend l [eof $f]
1.3384 + lappend l [gets $f]
1.3385 + lappend l [tell $f]
1.3386 + lappend l [fconfigure $f -translation]
1.3387 + lappend l [eof $f]
1.3388 + close $f
1.3389 + set l
1.3390 +} {hello 6 cr 0 there 12 cr 0}
1.3391 +test io-31.8 {Tcl_Write cr, Tcl_Gets lf} {
1.3392 + file delete $path(test1)
1.3393 + set f [open $path(test1) w]
1.3394 + fconfigure $f -translation cr
1.3395 + puts $f hello\nthere\nand\nhere
1.3396 + close $f
1.3397 + set f [open $path(test1) r]
1.3398 + fconfigure $f -translation lf
1.3399 + set l ""
1.3400 + lappend l [string length [gets $f]]
1.3401 + lappend l [tell $f]
1.3402 + lappend l [fconfigure $f -translation]
1.3403 + lappend l [eof $f]
1.3404 + lappend l [gets $f]
1.3405 + lappend l [tell $f]
1.3406 + lappend l [fconfigure $f -translation]
1.3407 + lappend l [eof $f]
1.3408 + close $f
1.3409 + set l
1.3410 +} {21 21 lf 1 {} 21 lf 1}
1.3411 +test io-31.9 {Tcl_Write cr, Tcl_Gets crlf} {
1.3412 + file delete $path(test1)
1.3413 + set f [open $path(test1) w]
1.3414 + fconfigure $f -translation cr
1.3415 + puts $f hello\nthere\nand\nhere
1.3416 + close $f
1.3417 + set f [open $path(test1) r]
1.3418 + fconfigure $f -translation crlf
1.3419 + set l ""
1.3420 + lappend l [string length [gets $f]]
1.3421 + lappend l [tell $f]
1.3422 + lappend l [fconfigure $f -translation]
1.3423 + lappend l [eof $f]
1.3424 + lappend l [gets $f]
1.3425 + lappend l [tell $f]
1.3426 + lappend l [fconfigure $f -translation]
1.3427 + lappend l [eof $f]
1.3428 + close $f
1.3429 + set l
1.3430 +} {21 21 crlf 1 {} 21 crlf 1}
1.3431 +test io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} {
1.3432 + file delete $path(test1)
1.3433 + set f [open $path(test1) w]
1.3434 + fconfigure $f -translation crlf
1.3435 + puts $f hello\nthere\nand\nhere
1.3436 + close $f
1.3437 + set f [open $path(test1) r]
1.3438 + fconfigure $f -translation crlf
1.3439 + set l ""
1.3440 + lappend l [gets $f]
1.3441 + lappend l [tell $f]
1.3442 + lappend l [fconfigure $f -translation]
1.3443 + lappend l [eof $f]
1.3444 + lappend l [gets $f]
1.3445 + lappend l [tell $f]
1.3446 + lappend l [fconfigure $f -translation]
1.3447 + lappend l [eof $f]
1.3448 + close $f
1.3449 + set l
1.3450 +} {hello 7 crlf 0 there 14 crlf 0}
1.3451 +test io-31.11 {Tcl_Write crlf, Tcl_Gets cr} {
1.3452 + file delete $path(test1)
1.3453 + set f [open $path(test1) w]
1.3454 + fconfigure $f -translation crlf
1.3455 + puts $f hello\nthere\nand\nhere
1.3456 + close $f
1.3457 + set f [open $path(test1) r]
1.3458 + fconfigure $f -translation cr
1.3459 + set l ""
1.3460 + lappend l [gets $f]
1.3461 + lappend l [tell $f]
1.3462 + lappend l [fconfigure $f -translation]
1.3463 + lappend l [eof $f]
1.3464 + lappend l [string length [gets $f]]
1.3465 + lappend l [tell $f]
1.3466 + lappend l [fconfigure $f -translation]
1.3467 + lappend l [eof $f]
1.3468 + close $f
1.3469 + set l
1.3470 +} {hello 6 cr 0 6 13 cr 0}
1.3471 +test io-31.12 {Tcl_Write crlf, Tcl_Gets lf} {
1.3472 + file delete $path(test1)
1.3473 + set f [open $path(test1) w]
1.3474 + fconfigure $f -translation crlf
1.3475 + puts $f hello\nthere\nand\nhere
1.3476 + close $f
1.3477 + set f [open $path(test1) r]
1.3478 + fconfigure $f -translation lf
1.3479 + set l ""
1.3480 + lappend l [string length [gets $f]]
1.3481 + lappend l [tell $f]
1.3482 + lappend l [fconfigure $f -translation]
1.3483 + lappend l [eof $f]
1.3484 + lappend l [string length [gets $f]]
1.3485 + lappend l [tell $f]
1.3486 + lappend l [fconfigure $f -translation]
1.3487 + lappend l [eof $f]
1.3488 + close $f
1.3489 + set l
1.3490 +} {6 7 lf 0 6 14 lf 0}
1.3491 +test io-31.13 {binary mode is synonym of lf mode} {
1.3492 + file delete $path(test1)
1.3493 + set f [open $path(test1) w]
1.3494 + fconfigure $f -translation binary
1.3495 + set x [fconfigure $f -translation]
1.3496 + close $f
1.3497 + set x
1.3498 +} lf
1.3499 +#
1.3500 +# Test io-9.14 has been removed because "auto" output translation mode is
1.3501 +# not supoprted.
1.3502 +#
1.3503 +test io-31.14 {Tcl_Write mixed, Tcl_Gets auto} {
1.3504 + file delete $path(test1)
1.3505 + set f [open $path(test1) w]
1.3506 + fconfigure $f -translation lf
1.3507 + puts $f hello\nthere\rand\r\nhere
1.3508 + close $f
1.3509 + set f [open $path(test1) r]
1.3510 + fconfigure $f -translation auto
1.3511 + set l ""
1.3512 + lappend l [gets $f]
1.3513 + lappend l [gets $f]
1.3514 + lappend l [gets $f]
1.3515 + lappend l [gets $f]
1.3516 + lappend l [eof $f]
1.3517 + lappend l [gets $f]
1.3518 + lappend l [eof $f]
1.3519 + close $f
1.3520 + set l
1.3521 +} {hello there and here 0 {} 1}
1.3522 +test io-31.15 {Tcl_Write mixed, Tcl_Gets auto} {
1.3523 + file delete $path(test1)
1.3524 + set f [open $path(test1) w]
1.3525 + fconfigure $f -translation lf
1.3526 + puts -nonewline $f hello\nthere\rand\r\nhere\r
1.3527 + close $f
1.3528 + set f [open $path(test1) r]
1.3529 + fconfigure $f -translation auto
1.3530 + set l ""
1.3531 + lappend l [gets $f]
1.3532 + lappend l [gets $f]
1.3533 + lappend l [gets $f]
1.3534 + lappend l [gets $f]
1.3535 + lappend l [eof $f]
1.3536 + lappend l [gets $f]
1.3537 + lappend l [eof $f]
1.3538 + close $f
1.3539 + set l
1.3540 +} {hello there and here 0 {} 1}
1.3541 +test io-31.16 {Tcl_Write mixed, Tcl_Gets auto} {
1.3542 + file delete $path(test1)
1.3543 + set f [open $path(test1) w]
1.3544 + fconfigure $f -translation lf
1.3545 + puts -nonewline $f hello\nthere\rand\r\nhere\n
1.3546 + close $f
1.3547 + set f [open $path(test1) r]
1.3548 + set l ""
1.3549 + lappend l [gets $f]
1.3550 + lappend l [gets $f]
1.3551 + lappend l [gets $f]
1.3552 + lappend l [gets $f]
1.3553 + lappend l [eof $f]
1.3554 + lappend l [gets $f]
1.3555 + lappend l [eof $f]
1.3556 + close $f
1.3557 + set l
1.3558 +} {hello there and here 0 {} 1}
1.3559 +test io-31.17 {Tcl_Write mixed, Tcl_Gets auto} {
1.3560 + file delete $path(test1)
1.3561 + set f [open $path(test1) w]
1.3562 + fconfigure $f -translation lf
1.3563 + puts -nonewline $f hello\nthere\rand\r\nhere\r\n
1.3564 + close $f
1.3565 + set f [open $path(test1) r]
1.3566 + fconfigure $f -translation auto
1.3567 + set l ""
1.3568 + lappend l [gets $f]
1.3569 + lappend l [gets $f]
1.3570 + lappend l [gets $f]
1.3571 + lappend l [gets $f]
1.3572 + lappend l [eof $f]
1.3573 + lappend l [gets $f]
1.3574 + lappend l [eof $f]
1.3575 + close $f
1.3576 + set l
1.3577 +} {hello there and here 0 {} 1}
1.3578 +test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} {
1.3579 + file delete $path(test1)
1.3580 + set f [open $path(test1) w]
1.3581 + fconfigure $f -translation lf
1.3582 + set s [format "hello\nthere\nand\rhere\n\%c" 26]
1.3583 + puts $f $s
1.3584 + close $f
1.3585 + set f [open $path(test1) r]
1.3586 + fconfigure $f -eofchar \x1a -translation auto
1.3587 + set l ""
1.3588 + lappend l [gets $f]
1.3589 + lappend l [gets $f]
1.3590 + lappend l [gets $f]
1.3591 + lappend l [gets $f]
1.3592 + lappend l [eof $f]
1.3593 + lappend l [gets $f]
1.3594 + lappend l [eof $f]
1.3595 + close $f
1.3596 + set l
1.3597 +} {hello there and here 0 {} 1}
1.3598 +test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} {
1.3599 + file delete $path(test1)
1.3600 + set f [open $path(test1) w]
1.3601 + fconfigure $f -eofchar \x1a -translation lf
1.3602 + puts $f hello\nthere\nand\rhere
1.3603 + close $f
1.3604 + set f [open $path(test1) r]
1.3605 + fconfigure $f -eofchar \x1a -translation auto
1.3606 + set l ""
1.3607 + lappend l [gets $f]
1.3608 + lappend l [gets $f]
1.3609 + lappend l [gets $f]
1.3610 + lappend l [gets $f]
1.3611 + lappend l [eof $f]
1.3612 + lappend l [gets $f]
1.3613 + lappend l [eof $f]
1.3614 + close $f
1.3615 + set l
1.3616 +} {hello there and here 0 {} 1}
1.3617 +test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} {
1.3618 + file delete $path(test1)
1.3619 + set f [open $path(test1) w]
1.3620 + fconfigure $f -translation lf
1.3621 + set s [format "abc\ndef\n%cqrs\ntuv" 26]
1.3622 + puts $f $s
1.3623 + close $f
1.3624 + set f [open $path(test1) r]
1.3625 + fconfigure $f -eofchar \x1a
1.3626 + fconfigure $f -translation auto
1.3627 + set l ""
1.3628 + lappend l [gets $f]
1.3629 + lappend l [gets $f]
1.3630 + lappend l [eof $f]
1.3631 + lappend l [gets $f]
1.3632 + lappend l [eof $f]
1.3633 + close $f
1.3634 + set l
1.3635 +} {abc def 0 {} 1}
1.3636 +test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} {
1.3637 + file delete $path(test1)
1.3638 + set f [open $path(test1) w]
1.3639 + fconfigure $f -translation lf
1.3640 + set s [format "abc\ndef\n%cqrs\ntuv" 26]
1.3641 + puts $f $s
1.3642 + close $f
1.3643 + set f [open $path(test1) r]
1.3644 + fconfigure $f -eofchar \x1a -translation auto
1.3645 + set l ""
1.3646 + lappend l [gets $f]
1.3647 + lappend l [gets $f]
1.3648 + lappend l [eof $f]
1.3649 + lappend l [gets $f]
1.3650 + lappend l [eof $f]
1.3651 + close $f
1.3652 + set l
1.3653 +} {abc def 0 {} 1}
1.3654 +test io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} {
1.3655 + file delete $path(test1)
1.3656 + set f [open $path(test1) w]
1.3657 + fconfigure $f -translation lf -eofchar {}
1.3658 + set s [format "abc\ndef\n%cqrs\ntuv" 26]
1.3659 + puts $f $s
1.3660 + close $f
1.3661 + set f [open $path(test1) r]
1.3662 + fconfigure $f -translation lf -eofchar {}
1.3663 + set l ""
1.3664 + lappend l [gets $f]
1.3665 + lappend l [gets $f]
1.3666 + lappend l [eof $f]
1.3667 + lappend l [gets $f]
1.3668 + lappend l [eof $f]
1.3669 + lappend l [gets $f]
1.3670 + lappend l [eof $f]
1.3671 + lappend l [gets $f]
1.3672 + lappend l [eof $f]
1.3673 + close $f
1.3674 + set l
1.3675 +} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
1.3676 +test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} {
1.3677 + file delete $path(test1)
1.3678 + set f [open $path(test1) w]
1.3679 + fconfigure $f -translation cr -eofchar {}
1.3680 + set s [format "abc\ndef\n%cqrs\ntuv" 26]
1.3681 + puts $f $s
1.3682 + close $f
1.3683 + set f [open $path(test1) r]
1.3684 + fconfigure $f -translation cr -eofchar {}
1.3685 + set l ""
1.3686 + lappend l [gets $f]
1.3687 + lappend l [gets $f]
1.3688 + lappend l [eof $f]
1.3689 + lappend l [gets $f]
1.3690 + lappend l [eof $f]
1.3691 + lappend l [gets $f]
1.3692 + lappend l [eof $f]
1.3693 + lappend l [gets $f]
1.3694 + lappend l [eof $f]
1.3695 + close $f
1.3696 + set l
1.3697 +} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
1.3698 +test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} {
1.3699 + file delete $path(test1)
1.3700 + set f [open $path(test1) w]
1.3701 + fconfigure $f -translation crlf -eofchar {}
1.3702 + set s [format "abc\ndef\n%cqrs\ntuv" 26]
1.3703 + puts $f $s
1.3704 + close $f
1.3705 + set f [open $path(test1) r]
1.3706 + fconfigure $f -translation crlf -eofchar {}
1.3707 + set l ""
1.3708 + lappend l [gets $f]
1.3709 + lappend l [gets $f]
1.3710 + lappend l [eof $f]
1.3711 + lappend l [gets $f]
1.3712 + lappend l [eof $f]
1.3713 + lappend l [gets $f]
1.3714 + lappend l [eof $f]
1.3715 + lappend l [gets $f]
1.3716 + lappend l [eof $f]
1.3717 + close $f
1.3718 + set l
1.3719 +} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
1.3720 +test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} {
1.3721 + file delete $path(test1)
1.3722 + set f [open $path(test1) w]
1.3723 + fconfigure $f -translation lf
1.3724 + set s [format "abc\ndef\n%cqrs\ntuv" 26]
1.3725 + puts $f $s
1.3726 + close $f
1.3727 + set f [open $path(test1) r]
1.3728 + fconfigure $f -translation auto -eofchar \x1a
1.3729 + set l ""
1.3730 + lappend l [gets $f]
1.3731 + lappend l [gets $f]
1.3732 + lappend l [eof $f]
1.3733 + lappend l [gets $f]
1.3734 + lappend l [eof $f]
1.3735 + close $f
1.3736 + set l
1.3737 +} {abc def 0 {} 1}
1.3738 +test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} {
1.3739 + file delete $path(test1)
1.3740 + set f [open $path(test1) w]
1.3741 + fconfigure $f -translation lf
1.3742 + set s [format "abc\ndef\n%cqrs\ntuv" 26]
1.3743 + puts $f $s
1.3744 + close $f
1.3745 + set f [open $path(test1) r]
1.3746 + fconfigure $f -translation lf -eofchar \x1a
1.3747 + set l ""
1.3748 + lappend l [gets $f]
1.3749 + lappend l [gets $f]
1.3750 + lappend l [eof $f]
1.3751 + lappend l [gets $f]
1.3752 + lappend l [eof $f]
1.3753 + close $f
1.3754 + set l
1.3755 +} {abc def 0 {} 1}
1.3756 +test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} {
1.3757 + file delete $path(test1)
1.3758 + set f [open $path(test1) w]
1.3759 + fconfigure $f -translation cr -eofchar {}
1.3760 + set s [format "abc\ndef\n%cqrs\ntuv" 26]
1.3761 + puts $f $s
1.3762 + close $f
1.3763 + set f [open $path(test1) r]
1.3764 + fconfigure $f -translation auto -eofchar \x1a
1.3765 + set l ""
1.3766 + lappend l [gets $f]
1.3767 + lappend l [gets $f]
1.3768 + lappend l [eof $f]
1.3769 + lappend l [gets $f]
1.3770 + lappend l [eof $f]
1.3771 + close $f
1.3772 + set l
1.3773 +} {abc def 0 {} 1}
1.3774 +test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} {
1.3775 + file delete $path(test1)
1.3776 + set f [open $path(test1) w]
1.3777 + fconfigure $f -translation cr -eofchar {}
1.3778 + set s [format "abc\ndef\n%cqrs\ntuv" 26]
1.3779 + puts $f $s
1.3780 + close $f
1.3781 + set f [open $path(test1) r]
1.3782 + fconfigure $f -translation cr -eofchar \x1a
1.3783 + set l ""
1.3784 + lappend l [gets $f]
1.3785 + lappend l [gets $f]
1.3786 + lappend l [eof $f]
1.3787 + lappend l [gets $f]
1.3788 + lappend l [eof $f]
1.3789 + close $f
1.3790 + set l
1.3791 +} {abc def 0 {} 1}
1.3792 +test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} {
1.3793 + file delete $path(test1)
1.3794 + set f [open $path(test1) w]
1.3795 + fconfigure $f -translation crlf -eofchar {}
1.3796 + set s [format "abc\ndef\n%cqrs\ntuv" 26]
1.3797 + puts $f $s
1.3798 + close $f
1.3799 + set f [open $path(test1) r]
1.3800 + fconfigure $f -translation auto -eofchar \x1a
1.3801 + set l ""
1.3802 + lappend l [gets $f]
1.3803 + lappend l [gets $f]
1.3804 + lappend l [eof $f]
1.3805 + lappend l [gets $f]
1.3806 + lappend l [eof $f]
1.3807 + close $f
1.3808 + set l
1.3809 +} {abc def 0 {} 1}
1.3810 +test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} {
1.3811 + file delete $path(test1)
1.3812 + set f [open $path(test1) w]
1.3813 + fconfigure $f -translation crlf -eofchar {}
1.3814 + set s [format "abc\ndef\n%cqrs\ntuv" 26]
1.3815 + puts $f $s
1.3816 + close $f
1.3817 + set f [open $path(test1) r]
1.3818 + fconfigure $f -translation crlf -eofchar \x1a
1.3819 + set l ""
1.3820 + lappend l [gets $f]
1.3821 + lappend l [gets $f]
1.3822 + lappend l [eof $f]
1.3823 + lappend l [gets $f]
1.3824 + lappend l [eof $f]
1.3825 + close $f
1.3826 + set l
1.3827 +} {abc def 0 {} 1}
1.3828 +test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} {
1.3829 + file delete $path(test1)
1.3830 + set f [open $path(test1) w]
1.3831 + fconfigure $f -translation crlf
1.3832 + set line "123456789ABCDE" ;# 14 char plus crlf
1.3833 + puts -nonewline $f x ;# shift crlf across block boundary
1.3834 + for {set i 0} {$i < 700} {incr i} {
1.3835 + puts $f $line
1.3836 + }
1.3837 + close $f
1.3838 + set f [open $path(test1) r]
1.3839 + fconfigure $f -translation crlf
1.3840 + set c ""
1.3841 + while {[gets $f line] >= 0} {
1.3842 + append c $line\n
1.3843 + }
1.3844 + close $f
1.3845 + string length $c
1.3846 +} [expr 700*15+1]
1.3847 +test io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} {
1.3848 + file delete $path(test1)
1.3849 + set f [open $path(test1) w]
1.3850 + fconfigure $f -translation crlf
1.3851 + set line "123456789ABCDE" ;# 14 char plus crlf
1.3852 + puts -nonewline $f x ;# shift crlf across block boundary
1.3853 + for {set i 0} {$i < 700} {incr i} {
1.3854 + puts $f $line
1.3855 + }
1.3856 + close $f
1.3857 + set f [open $path(test1) r]
1.3858 + fconfigure $f -translation auto
1.3859 + set c ""
1.3860 + while {[gets $f line] >= 0} {
1.3861 + append c $line\n
1.3862 + }
1.3863 + close $f
1.3864 + string length $c
1.3865 +} [expr 700*15+1]
1.3866 +
1.3867 +
1.3868 +# Test Tcl_Read and buffering.
1.3869 +
1.3870 +test io-32.1 {Tcl_Read, channel not readable} {
1.3871 + list [catch {read stdout} msg] $msg
1.3872 +} {1 {channel "stdout" wasn't opened for reading}}
1.3873 +test io-32.2 {Tcl_Read, zero byte count} {
1.3874 + read stdin 0
1.3875 +} ""
1.3876 +test io-32.3 {Tcl_Read, negative byte count} {
1.3877 + set f [open $path(longfile) r]
1.3878 + set l [list [catch {read $f -1} msg] $msg]
1.3879 + close $f
1.3880 + set l
1.3881 +} {1 {bad argument "-1": should be "nonewline"}}
1.3882 +test io-32.4 {Tcl_Read, positive byte count} {
1.3883 + set f [open $path(longfile) r]
1.3884 + set x [read $f 1024]
1.3885 + set s [string length $x]
1.3886 + unset x
1.3887 + close $f
1.3888 + set s
1.3889 +} 1024
1.3890 +test io-32.5 {Tcl_Read, multiple buffers} {
1.3891 + set f [open $path(longfile) r]
1.3892 + fconfigure $f -buffersize 100
1.3893 + set x [read $f 1024]
1.3894 + set s [string length $x]
1.3895 + unset x
1.3896 + close $f
1.3897 + set s
1.3898 +} 1024
1.3899 +test io-32.6 {Tcl_Read, very large read} {
1.3900 + set f1 [open $path(longfile) r]
1.3901 + set z [read $f1 1000000]
1.3902 + close $f1
1.3903 + set l [string length $z]
1.3904 + set x ok
1.3905 + set z [file size $path(longfile)]
1.3906 + if {$z != $l} {
1.3907 + set x broken
1.3908 + }
1.3909 + set x
1.3910 +} ok
1.3911 +test io-32.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
1.3912 + set f1 [open $path(longfile) r]
1.3913 + fconfigure $f1 -blocking off
1.3914 + set z [read $f1 20]
1.3915 + close $f1
1.3916 + set l [string length $z]
1.3917 + set x ok
1.3918 + if {$l != 20} {
1.3919 + set x broken
1.3920 + }
1.3921 + set x
1.3922 +} ok
1.3923 +test io-32.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
1.3924 + set f1 [open $path(longfile) r]
1.3925 + fconfigure $f1 -blocking off
1.3926 + set z [read $f1 1000000]
1.3927 + close $f1
1.3928 + set x ok
1.3929 + set l [string length $z]
1.3930 + set z [file size $path(longfile)]
1.3931 + if {$z != $l} {
1.3932 + set x broken
1.3933 + }
1.3934 + set x
1.3935 +} ok
1.3936 +test io-32.9 {Tcl_Read, read to end of file} {
1.3937 + set f1 [open $path(longfile) r]
1.3938 + set z [read $f1]
1.3939 + close $f1
1.3940 + set l [string length $z]
1.3941 + set x ok
1.3942 + set z [file size $path(longfile)]
1.3943 + if {$z != $l} {
1.3944 + set x broken
1.3945 + }
1.3946 + set x
1.3947 +} ok
1.3948 +test io-32.10 {Tcl_Read from a pipe} {stdio openpipe} {
1.3949 + file delete $path(pipe)
1.3950 + set f1 [open $path(pipe) w]
1.3951 + puts $f1 {puts [gets stdin]}
1.3952 + close $f1
1.3953 + set f1 [open "|[list [interpreter] $path(pipe)]" r+]
1.3954 + puts $f1 hello
1.3955 + flush $f1
1.3956 + set x [read $f1]
1.3957 + close $f1
1.3958 + set x
1.3959 +} "hello\n"
1.3960 +test io-32.11 {Tcl_Read from a pipe} {stdio openpipe} {
1.3961 + file delete $path(pipe)
1.3962 + set f1 [open $path(pipe) w]
1.3963 + puts $f1 {puts [gets stdin]}
1.3964 + puts $f1 {puts [gets stdin]}
1.3965 + close $f1
1.3966 + set f1 [open "|[list [interpreter] $path(pipe)]" r+]
1.3967 + puts $f1 hello
1.3968 + flush $f1
1.3969 + set x ""
1.3970 + lappend x [read $f1 6]
1.3971 + puts $f1 hello
1.3972 + flush $f1
1.3973 + lappend x [read $f1]
1.3974 + close $f1
1.3975 + set x
1.3976 +} {{hello
1.3977 +} {hello
1.3978 +}}
1.3979 +test io-32.12 {Tcl_Read, -nonewline} {
1.3980 + file delete $path(test1)
1.3981 + set f1 [open $path(test1) w]
1.3982 + puts $f1 hello
1.3983 + puts $f1 bye
1.3984 + close $f1
1.3985 + set f1 [open $path(test1) r]
1.3986 + set c [read -nonewline $f1]
1.3987 + close $f1
1.3988 + set c
1.3989 +} {hello
1.3990 +bye}
1.3991 +test io-32.13 {Tcl_Read, -nonewline} {
1.3992 + file delete $path(test1)
1.3993 + set f1 [open $path(test1) w]
1.3994 + puts $f1 hello
1.3995 + puts $f1 bye
1.3996 + close $f1
1.3997 + set f1 [open $path(test1) r]
1.3998 + set c [read -nonewline $f1]
1.3999 + close $f1
1.4000 + list [string length $c] $c
1.4001 +} {9 {hello
1.4002 +bye}}
1.4003 +test io-32.14 {Tcl_Read, reading in small chunks} {
1.4004 + file delete $path(test1)
1.4005 + set f [open $path(test1) w]
1.4006 + puts $f "Two lines: this one"
1.4007 + puts $f "and this one"
1.4008 + close $f
1.4009 + set f [open $path(test1)]
1.4010 + set x [list [read $f 1] [read $f 2] [read $f]]
1.4011 + close $f
1.4012 + set x
1.4013 +} {T wo { lines: this one
1.4014 +and this one
1.4015 +}}
1.4016 +test io-32.15 {Tcl_Read, asking for more input than available} {
1.4017 + file delete $path(test1)
1.4018 + set f [open $path(test1) w]
1.4019 + puts $f "Two lines: this one"
1.4020 + puts $f "and this one"
1.4021 + close $f
1.4022 + set f [open $path(test1)]
1.4023 + set x [read $f 100]
1.4024 + close $f
1.4025 + set x
1.4026 +} {Two lines: this one
1.4027 +and this one
1.4028 +}
1.4029 +test io-32.16 {Tcl_Read, read to end of file with -nonewline} {
1.4030 + file delete $path(test1)
1.4031 + set f [open $path(test1) w]
1.4032 + puts $f "Two lines: this one"
1.4033 + puts $f "and this one"
1.4034 + close $f
1.4035 + set f [open $path(test1)]
1.4036 + set x [read -nonewline $f]
1.4037 + close $f
1.4038 + set x
1.4039 +} {Two lines: this one
1.4040 +and this one}
1.4041 +
1.4042 +# Test Tcl_Gets.
1.4043 +
1.4044 +test io-33.1 {Tcl_Gets, reading what was written} {
1.4045 + file delete $path(test1)
1.4046 + set f1 [open $path(test1) w]
1.4047 + set y "first line"
1.4048 + puts $f1 $y
1.4049 + close $f1
1.4050 + set f1 [open $path(test1) r]
1.4051 + set x [gets $f1]
1.4052 + set z ok
1.4053 + if {"$x" != "$y"} {
1.4054 + set z broken
1.4055 + }
1.4056 + close $f1
1.4057 + set z
1.4058 +} ok
1.4059 +test io-33.2 {Tcl_Gets into variable} {
1.4060 + set f1 [open $path(longfile) r]
1.4061 + set c [gets $f1 x]
1.4062 + set l [string length x]
1.4063 + set z ok
1.4064 + if {$l != $l} {
1.4065 + set z broken
1.4066 + }
1.4067 + close $f1
1.4068 + set z
1.4069 +} ok
1.4070 +test io-33.3 {Tcl_Gets from pipe} {stdio openpipe} {
1.4071 + file delete $path(pipe)
1.4072 + set f1 [open $path(pipe) w]
1.4073 + puts $f1 {puts [gets stdin]}
1.4074 + close $f1
1.4075 + set f1 [open "|[list [interpreter] $path(pipe)]" r+]
1.4076 + puts $f1 hello
1.4077 + flush $f1
1.4078 + set x [gets $f1]
1.4079 + close $f1
1.4080 + set z ok
1.4081 + if {"$x" != "hello"} {
1.4082 + set z broken
1.4083 + }
1.4084 + set z
1.4085 +} ok
1.4086 +test io-33.4 {Tcl_Gets with long line} {
1.4087 + file delete $path(test3)
1.4088 + set f [open $path(test3) w]
1.4089 + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
1.4090 + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
1.4091 + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
1.4092 + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
1.4093 + puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
1.4094 + close $f
1.4095 + set f [open $path(test3)]
1.4096 + set x [gets $f]
1.4097 + close $f
1.4098 + set x
1.4099 +} {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
1.4100 +test io-33.5 {Tcl_Gets with long line} {
1.4101 + set f [open $path(test3)]
1.4102 + set x [gets $f y]
1.4103 + close $f
1.4104 + list $x $y
1.4105 +} {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
1.4106 +test io-33.6 {Tcl_Gets and end of file} {
1.4107 + file delete $path(test3)
1.4108 + set f [open $path(test3) w]
1.4109 + puts -nonewline $f "Test1\nTest2"
1.4110 + close $f
1.4111 + set f [open $path(test3)]
1.4112 + set x {}
1.4113 + set y {}
1.4114 + lappend x [gets $f y] $y
1.4115 + set y {}
1.4116 + lappend x [gets $f y] $y
1.4117 + set y {}
1.4118 + lappend x [gets $f y] $y
1.4119 + close $f
1.4120 + set x
1.4121 +} {5 Test1 5 Test2 -1 {}}
1.4122 +test io-33.7 {Tcl_Gets and bad variable} {
1.4123 + set f [open $path(test3) w]
1.4124 + puts $f "Line 1"
1.4125 + puts $f "Line 2"
1.4126 + close $f
1.4127 + catch {unset x}
1.4128 + set x 24
1.4129 + set f [open $path(test3) r]
1.4130 + set result [list [catch {gets $f x(0)} msg] $msg]
1.4131 + close $f
1.4132 + set result
1.4133 +} {1 {can't set "x(0)": variable isn't array}}
1.4134 +test io-33.8 {Tcl_Gets, exercising double buffering} {
1.4135 + set f [open $path(test3) w]
1.4136 + fconfigure $f -translation lf -eofchar {}
1.4137 + set x ""
1.4138 + for {set y 0} {$y < 99} {incr y} {set x "a$x"}
1.4139 + for {set y 0} {$y < 100} {incr y} {puts $f $x}
1.4140 + close $f
1.4141 + set f [open $path(test3) r]
1.4142 + fconfigure $f -translation lf
1.4143 + for {set y 0} {$y < 100} {incr y} {gets $f}
1.4144 + close $f
1.4145 + set y
1.4146 +} 100
1.4147 +test io-33.9 {Tcl_Gets, exercising double buffering} {
1.4148 + set f [open $path(test3) w]
1.4149 + fconfigure $f -translation lf -eofchar {}
1.4150 + set x ""
1.4151 + for {set y 0} {$y < 99} {incr y} {set x "a$x"}
1.4152 + for {set y 0} {$y < 200} {incr y} {puts $f $x}
1.4153 + close $f
1.4154 + set f [open $path(test3) r]
1.4155 + fconfigure $f -translation lf
1.4156 + for {set y 0} {$y < 200} {incr y} {gets $f}
1.4157 + close $f
1.4158 + set y
1.4159 +} 200
1.4160 +test io-33.10 {Tcl_Gets, exercising double buffering} {
1.4161 + set f [open $path(test3) w]
1.4162 + fconfigure $f -translation lf -eofchar {}
1.4163 + set x ""
1.4164 + for {set y 0} {$y < 99} {incr y} {set x "a$x"}
1.4165 + for {set y 0} {$y < 300} {incr y} {puts $f $x}
1.4166 + close $f
1.4167 + set f [open $path(test3) r]
1.4168 + fconfigure $f -translation lf
1.4169 + for {set y 0} {$y < 300} {incr y} {gets $f}
1.4170 + close $f
1.4171 + set y
1.4172 +} 300
1.4173 +
1.4174 +# Test Tcl_Seek and Tcl_Tell.
1.4175 +
1.4176 +test io-34.1 {Tcl_Seek to current position at start of file} {
1.4177 + set f1 [open $path(longfile) r]
1.4178 + seek $f1 0 current
1.4179 + set c [tell $f1]
1.4180 + close $f1
1.4181 + set c
1.4182 +} 0
1.4183 +test io-34.2 {Tcl_Seek to offset from start} {
1.4184 + file delete $path(test1)
1.4185 + set f1 [open $path(test1) w]
1.4186 + fconfigure $f1 -translation lf -eofchar {}
1.4187 + puts $f1 "abcdefghijklmnopqrstuvwxyz"
1.4188 + puts $f1 "abcdefghijklmnopqrstuvwxyz"
1.4189 + close $f1
1.4190 + set f1 [open $path(test1) r]
1.4191 + seek $f1 10 start
1.4192 + set c [tell $f1]
1.4193 + close $f1
1.4194 + set c
1.4195 +} 10
1.4196 +test io-34.3 {Tcl_Seek to end of file} {
1.4197 + file delete $path(test1)
1.4198 + set f1 [open $path(test1) w]
1.4199 + fconfigure $f1 -translation lf -eofchar {}
1.4200 + puts $f1 "abcdefghijklmnopqrstuvwxyz"
1.4201 + puts $f1 "abcdefghijklmnopqrstuvwxyz"
1.4202 + close $f1
1.4203 + set f1 [open $path(test1) r]
1.4204 + seek $f1 0 end
1.4205 + set c [tell $f1]
1.4206 + close $f1
1.4207 + set c
1.4208 +} 54
1.4209 +test io-34.4 {Tcl_Seek to offset from end of file} {
1.4210 + file delete $path(test1)
1.4211 + set f1 [open $path(test1) w]
1.4212 + fconfigure $f1 -translation lf -eofchar {}
1.4213 + puts $f1 "abcdefghijklmnopqrstuvwxyz"
1.4214 + puts $f1 "abcdefghijklmnopqrstuvwxyz"
1.4215 + close $f1
1.4216 + set f1 [open $path(test1) r]
1.4217 + seek $f1 -10 end
1.4218 + set c [tell $f1]
1.4219 + close $f1
1.4220 + set c
1.4221 +} 44
1.4222 +test io-34.5 {Tcl_Seek to offset from current position} {
1.4223 + file delete $path(test1)
1.4224 + set f1 [open $path(test1) w]
1.4225 + fconfigure $f1 -translation lf -eofchar {}
1.4226 + puts $f1 "abcdefghijklmnopqrstuvwxyz"
1.4227 + puts $f1 "abcdefghijklmnopqrstuvwxyz"
1.4228 + close $f1
1.4229 + set f1 [open $path(test1) r]
1.4230 + seek $f1 10 current
1.4231 + seek $f1 10 current
1.4232 + set c [tell $f1]
1.4233 + close $f1
1.4234 + set c
1.4235 +} 20
1.4236 +test io-34.6 {Tcl_Seek to offset from end of file} {
1.4237 + file delete $path(test1)
1.4238 + set f1 [open $path(test1) w]
1.4239 + fconfigure $f1 -translation lf -eofchar {}
1.4240 + puts $f1 "abcdefghijklmnopqrstuvwxyz"
1.4241 + puts $f1 "abcdefghijklmnopqrstuvwxyz"
1.4242 + close $f1
1.4243 + set f1 [open $path(test1) r]
1.4244 + seek $f1 -10 end
1.4245 + set c [tell $f1]
1.4246 + set r [read $f1]
1.4247 + close $f1
1.4248 + list $c $r
1.4249 +} {44 {rstuvwxyz
1.4250 +}}
1.4251 +test io-34.7 {Tcl_Seek to offset from end of file, then to current position} {
1.4252 + file delete $path(test1)
1.4253 + set f1 [open $path(test1) w]
1.4254 + fconfigure $f1 -translation lf -eofchar {}
1.4255 + puts $f1 "abcdefghijklmnopqrstuvwxyz"
1.4256 + puts $f1 "abcdefghijklmnopqrstuvwxyz"
1.4257 + close $f1
1.4258 + set f1 [open $path(test1) r]
1.4259 + seek $f1 -10 end
1.4260 + set c1 [tell $f1]
1.4261 + set r1 [read $f1 5]
1.4262 + seek $f1 0 current
1.4263 + set c2 [tell $f1]
1.4264 + close $f1
1.4265 + list $c1 $r1 $c2
1.4266 +} {44 rstuv 49}
1.4267 +test io-34.8 {Tcl_Seek on pipes: not supported} {stdio openpipe} {
1.4268 + set f1 [open "|[list [interpreter]]" r+]
1.4269 + set x [list [catch {seek $f1 0 current} msg] $msg]
1.4270 + close $f1
1.4271 + regsub {".*":} $x {"":} x
1.4272 + string tolower $x
1.4273 +} {1 {error during seek on "": invalid argument}}
1.4274 +test io-34.9 {Tcl_Seek, testing buffered input flushing} {
1.4275 + file delete $path(test3)
1.4276 + set f [open $path(test3) w]
1.4277 + fconfigure $f -eofchar {}
1.4278 + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
1.4279 + close $f
1.4280 + set f [open $path(test3) RDWR]
1.4281 + set x [read $f 1]
1.4282 + seek $f 3
1.4283 + lappend x [read $f 1]
1.4284 + seek $f 0 start
1.4285 + lappend x [read $f 1]
1.4286 + seek $f 10 current
1.4287 + lappend x [read $f 1]
1.4288 + seek $f -2 end
1.4289 + lappend x [read $f 1]
1.4290 + seek $f 50 end
1.4291 + lappend x [read $f 1]
1.4292 + seek $f 1
1.4293 + lappend x [read $f 1]
1.4294 + close $f
1.4295 + set x
1.4296 +} {a d a l Y {} b}
1.4297 +
1.4298 +set path(test3) [makeFile {} test3]
1.4299 +
1.4300 +test io-34.10 {Tcl_Seek testing flushing of buffered input} {
1.4301 + set f [open $path(test3) w]
1.4302 + fconfigure $f -translation lf
1.4303 + puts $f xyz\n123
1.4304 + close $f
1.4305 + set f [open $path(test3) r+]
1.4306 + fconfigure $f -translation lf
1.4307 + set x [gets $f]
1.4308 + seek $f 0 current
1.4309 + puts $f 456
1.4310 + close $f
1.4311 + list $x [viewFile test3]
1.4312 +} "xyz {xyz
1.4313 +456}"
1.4314 +test io-34.11 {Tcl_Seek testing flushing of buffered output} {
1.4315 + set f [open $path(test3) w]
1.4316 + puts $f xyz\n123
1.4317 + close $f
1.4318 + set f [open $path(test3) w+]
1.4319 + puts $f xyzzy
1.4320 + seek $f 2
1.4321 + set x [gets $f]
1.4322 + close $f
1.4323 + list $x [viewFile test3]
1.4324 +} "zzy xyzzy"
1.4325 +test io-34.12 {Tcl_Seek testing combination of write, seek back and read} {
1.4326 + set f [open $path(test3) w]
1.4327 + fconfigure $f -translation lf -eofchar {}
1.4328 + puts $f xyz\n123
1.4329 + close $f
1.4330 + set f [open $path(test3) a+]
1.4331 + fconfigure $f -translation lf -eofchar {}
1.4332 + puts $f xyzzy
1.4333 + flush $f
1.4334 + set x [tell $f]
1.4335 + seek $f -4 cur
1.4336 + set y [gets $f]
1.4337 + close $f
1.4338 + list $x [viewFile test3] $y
1.4339 +} {14 {xyz
1.4340 +123
1.4341 +xyzzy} zzy}
1.4342 +test io-34.13 {Tcl_Tell at start of file} {
1.4343 + file delete $path(test1)
1.4344 + set f1 [open $path(test1) w]
1.4345 + set p [tell $f1]
1.4346 + close $f1
1.4347 + set p
1.4348 +} 0
1.4349 +test io-34.14 {Tcl_Tell after seek to end of file} {
1.4350 + file delete $path(test1)
1.4351 + set f1 [open $path(test1) w]
1.4352 + fconfigure $f1 -translation lf -eofchar {}
1.4353 + puts $f1 "abcdefghijklmnopqrstuvwxyz"
1.4354 + puts $f1 "abcdefghijklmnopqrstuvwxyz"
1.4355 + close $f1
1.4356 + set f1 [open $path(test1) r]
1.4357 + seek $f1 0 end
1.4358 + set c1 [tell $f1]
1.4359 + close $f1
1.4360 + set c1
1.4361 +} 54
1.4362 +test io-34.15 {Tcl_Tell combined with seeking} {
1.4363 + file delete $path(test1)
1.4364 + set f1 [open $path(test1) w]
1.4365 + fconfigure $f1 -translation lf -eofchar {}
1.4366 + puts $f1 "abcdefghijklmnopqrstuvwxyz"
1.4367 + puts $f1 "abcdefghijklmnopqrstuvwxyz"
1.4368 + close $f1
1.4369 + set f1 [open $path(test1) r]
1.4370 + seek $f1 10 start
1.4371 + set c1 [tell $f1]
1.4372 + seek $f1 10 current
1.4373 + set c2 [tell $f1]
1.4374 + close $f1
1.4375 + list $c1 $c2
1.4376 +} {10 20}
1.4377 +test io-34.16 {Tcl_tell on pipe: always -1} {stdio openpipe} {
1.4378 + set f1 [open "|[list [interpreter]]" r+]
1.4379 + set c [tell $f1]
1.4380 + close $f1
1.4381 + set c
1.4382 +} -1
1.4383 +test io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} {
1.4384 + set f1 [open "|[list [interpreter]]" r+]
1.4385 + puts $f1 {puts hello}
1.4386 + flush $f1
1.4387 + set c [tell $f1]
1.4388 + gets $f1
1.4389 + close $f1
1.4390 + set c
1.4391 +} -1
1.4392 +test io-34.18 {Tcl_Tell combined with seeking and reading} {
1.4393 + file delete $path(test2)
1.4394 + set f [open $path(test2) w]
1.4395 + fconfigure $f -translation lf -eofchar {}
1.4396 + puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n"
1.4397 + close $f
1.4398 + set f [open $path(test2)]
1.4399 + fconfigure $f -translation lf
1.4400 + set x [tell $f]
1.4401 + read $f 3
1.4402 + lappend x [tell $f]
1.4403 + seek $f 2
1.4404 + lappend x [tell $f]
1.4405 + seek $f 10 current
1.4406 + lappend x [tell $f]
1.4407 + seek $f 0 end
1.4408 + lappend x [tell $f]
1.4409 + close $f
1.4410 + set x
1.4411 +} {0 3 2 12 30}
1.4412 +test io-34.19 {Tcl_Tell combined with opening in append mode} {
1.4413 + set f [open $path(test3) w]
1.4414 + fconfigure $f -translation lf -eofchar {}
1.4415 + puts $f "abcdefghijklmnopqrstuvwxyz"
1.4416 + puts $f "abcdefghijklmnopqrstuvwxyz"
1.4417 + close $f
1.4418 + set f [open $path(test3) a]
1.4419 + set c [tell $f]
1.4420 + close $f
1.4421 + set c
1.4422 +} 54
1.4423 +test io-34.20 {Tcl_Tell combined with writing} {
1.4424 + set f [open $path(test3) w]
1.4425 + set l ""
1.4426 + seek $f 29 start
1.4427 + lappend l [tell $f]
1.4428 + puts -nonewline $f a
1.4429 + seek $f 39 start
1.4430 + lappend l [tell $f]
1.4431 + puts -nonewline $f a
1.4432 + lappend l [tell $f]
1.4433 + seek $f 407 end
1.4434 + lappend l [tell $f]
1.4435 + close $f
1.4436 + set l
1.4437 +} {29 39 40 447}
1.4438 +test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} {
1.4439 + file delete $path(test3)
1.4440 + set f [open $path(test3) w]
1.4441 + fconfigure $f -encoding binary
1.4442 + set l ""
1.4443 + lappend l [tell $f]
1.4444 + puts -nonewline $f abcdef
1.4445 + lappend l [tell $f]
1.4446 + flush $f
1.4447 + lappend l [tell $f]
1.4448 + # 4GB offset!
1.4449 + seek $f 0x100000000
1.4450 + lappend l [tell $f]
1.4451 + puts -nonewline $f abcdef
1.4452 + lappend l [tell $f]
1.4453 + close $f
1.4454 + lappend l [file size $f]
1.4455 + # truncate...
1.4456 + close [open $path(test3) w]
1.4457 + lappend l [file size $f]
1.4458 + set l
1.4459 +} {0 6 6 4294967296 4294967302 4294967302 0}
1.4460 +
1.4461 +# Test Tcl_Eof
1.4462 +
1.4463 +test io-35.1 {Tcl_Eof} {
1.4464 + file delete $path(test1)
1.4465 + set f [open $path(test1) w]
1.4466 + puts $f hello
1.4467 + puts $f hello
1.4468 + close $f
1.4469 + set f [open $path(test1)]
1.4470 + set x [eof $f]
1.4471 + lappend x [eof $f]
1.4472 + gets $f
1.4473 + lappend x [eof $f]
1.4474 + gets $f
1.4475 + lappend x [eof $f]
1.4476 + gets $f
1.4477 + lappend x [eof $f]
1.4478 + lappend x [eof $f]
1.4479 + close $f
1.4480 + set x
1.4481 +} {0 0 0 0 1 1}
1.4482 +test io-35.2 {Tcl_Eof with pipe} {stdio openpipe} {
1.4483 + file delete $path(pipe)
1.4484 + set f1 [open $path(pipe) w]
1.4485 + puts $f1 {gets stdin}
1.4486 + puts $f1 {puts hello}
1.4487 + close $f1
1.4488 + set f1 [open "|[list [interpreter] $path(pipe)]" r+]
1.4489 + puts $f1 hello
1.4490 + set x [eof $f1]
1.4491 + flush $f1
1.4492 + lappend x [eof $f1]
1.4493 + gets $f1
1.4494 + lappend x [eof $f1]
1.4495 + gets $f1
1.4496 + lappend x [eof $f1]
1.4497 + close $f1
1.4498 + set x
1.4499 +} {0 0 0 1}
1.4500 +test io-35.3 {Tcl_Eof with pipe} {stdio openpipe} {
1.4501 + file delete $path(pipe)
1.4502 + set f1 [open $path(pipe) w]
1.4503 + puts $f1 {gets stdin}
1.4504 + puts $f1 {puts hello}
1.4505 + close $f1
1.4506 + set f1 [open "|[list [interpreter] $path(pipe)]" r+]
1.4507 + puts $f1 hello
1.4508 + set x [eof $f1]
1.4509 + flush $f1
1.4510 + lappend x [eof $f1]
1.4511 + gets $f1
1.4512 + lappend x [eof $f1]
1.4513 + gets $f1
1.4514 + lappend x [eof $f1]
1.4515 + gets $f1
1.4516 + lappend x [eof $f1]
1.4517 + gets $f1
1.4518 + lappend x [eof $f1]
1.4519 + close $f1
1.4520 + set x
1.4521 +} {0 0 0 1 1 1}
1.4522 +test io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} {
1.4523 + file delete $path(test1)
1.4524 + set f [open $path(test1) w]
1.4525 + close $f
1.4526 + set f [open $path(test1) r]
1.4527 + fconfigure $f -blocking off
1.4528 + set l ""
1.4529 + lappend l [gets $f]
1.4530 + lappend l [eof $f]
1.4531 + close $f
1.4532 + set l
1.4533 +} {{} 1}
1.4534 +test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio openpipe} {
1.4535 + file delete $path(pipe)
1.4536 + set f [open $path(pipe) w]
1.4537 + puts $f {
1.4538 + exit
1.4539 + }
1.4540 + close $f
1.4541 + set f [open "|[list [interpreter] $path(pipe)]" r]
1.4542 + set l ""
1.4543 + lappend l [gets $f]
1.4544 + lappend l [eof $f]
1.4545 + close $f
1.4546 + set l
1.4547 +} {{} 1}
1.4548 +test io-35.6 {Tcl_Eof, eof char, lf write, auto read} {
1.4549 + file delete $path(test1)
1.4550 + set f [open $path(test1) w]
1.4551 + fconfigure $f -translation lf -eofchar \x1a
1.4552 + puts $f abc\ndef
1.4553 + close $f
1.4554 + set s [file size $path(test1)]
1.4555 + set f [open $path(test1) r]
1.4556 + fconfigure $f -translation auto -eofchar \x1a
1.4557 + set l [string length [read $f]]
1.4558 + set e [eof $f]
1.4559 + close $f
1.4560 + list $s $l $e
1.4561 +} {9 8 1}
1.4562 +test io-35.7 {Tcl_Eof, eof char, lf write, lf read} {
1.4563 + file delete $path(test1)
1.4564 + set f [open $path(test1) w]
1.4565 + fconfigure $f -translation lf -eofchar \x1a
1.4566 + puts $f abc\ndef
1.4567 + close $f
1.4568 + set s [file size $path(test1)]
1.4569 + set f [open $path(test1) r]
1.4570 + fconfigure $f -translation lf -eofchar \x1a
1.4571 + set l [string length [read $f]]
1.4572 + set e [eof $f]
1.4573 + close $f
1.4574 + list $s $l $e
1.4575 +} {9 8 1}
1.4576 +test io-35.8 {Tcl_Eof, eof char, cr write, auto read} {
1.4577 + file delete $path(test1)
1.4578 + set f [open $path(test1) w]
1.4579 + fconfigure $f -translation cr -eofchar \x1a
1.4580 + puts $f abc\ndef
1.4581 + close $f
1.4582 + set s [file size $path(test1)]
1.4583 + set f [open $path(test1) r]
1.4584 + fconfigure $f -translation auto -eofchar \x1a
1.4585 + set l [string length [read $f]]
1.4586 + set e [eof $f]
1.4587 + close $f
1.4588 + list $s $l $e
1.4589 +} {9 8 1}
1.4590 +test io-35.9 {Tcl_Eof, eof char, cr write, cr read} {
1.4591 + file delete $path(test1)
1.4592 + set f [open $path(test1) w]
1.4593 + fconfigure $f -translation cr -eofchar \x1a
1.4594 + puts $f abc\ndef
1.4595 + close $f
1.4596 + set s [file size $path(test1)]
1.4597 + set f [open $path(test1) r]
1.4598 + fconfigure $f -translation cr -eofchar \x1a
1.4599 + set l [string length [read $f]]
1.4600 + set e [eof $f]
1.4601 + close $f
1.4602 + list $s $l $e
1.4603 +} {9 8 1}
1.4604 +test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} {
1.4605 + file delete $path(test1)
1.4606 + set f [open $path(test1) w]
1.4607 + fconfigure $f -translation crlf -eofchar \x1a
1.4608 + puts $f abc\ndef
1.4609 + close $f
1.4610 + set s [file size $path(test1)]
1.4611 + set f [open $path(test1) r]
1.4612 + fconfigure $f -translation auto -eofchar \x1a
1.4613 + set l [string length [read $f]]
1.4614 + set e [eof $f]
1.4615 + close $f
1.4616 + list $s $l $e
1.4617 +} {11 8 1}
1.4618 +test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} {
1.4619 + file delete $path(test1)
1.4620 + set f [open $path(test1) w]
1.4621 + fconfigure $f -translation crlf -eofchar \x1a
1.4622 + puts $f abc\ndef
1.4623 + close $f
1.4624 + set s [file size $path(test1)]
1.4625 + set f [open $path(test1) r]
1.4626 + fconfigure $f -translation crlf -eofchar \x1a
1.4627 + set l [string length [read $f]]
1.4628 + set e [eof $f]
1.4629 + close $f
1.4630 + list $s $l $e
1.4631 +} {11 8 1}
1.4632 +test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} {
1.4633 + file delete $path(test1)
1.4634 + set f [open $path(test1) w]
1.4635 + fconfigure $f -translation lf -eofchar {}
1.4636 + set i [format abc\ndef\n%cqrs\nuvw 26]
1.4637 + puts $f $i
1.4638 + close $f
1.4639 + set c [file size $path(test1)]
1.4640 + set f [open $path(test1) r]
1.4641 + fconfigure $f -translation auto -eofchar \x1a
1.4642 + set l [string length [read $f]]
1.4643 + set e [eof $f]
1.4644 + close $f
1.4645 + list $c $l $e
1.4646 +} {17 8 1}
1.4647 +test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} {
1.4648 + file delete $path(test1)
1.4649 + set f [open $path(test1) w]
1.4650 + fconfigure $f -translation lf -eofchar {}
1.4651 + set i [format abc\ndef\n%cqrs\nuvw 26]
1.4652 + puts $f $i
1.4653 + close $f
1.4654 + set c [file size $path(test1)]
1.4655 + set f [open $path(test1) r]
1.4656 + fconfigure $f -translation lf -eofchar \x1a
1.4657 + set l [string length [read $f]]
1.4658 + set e [eof $f]
1.4659 + close $f
1.4660 + list $c $l $e
1.4661 +} {17 8 1}
1.4662 +test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} {
1.4663 + file delete $path(test1)
1.4664 + set f [open $path(test1) w]
1.4665 + fconfigure $f -translation cr -eofchar {}
1.4666 + set i [format abc\ndef\n%cqrs\nuvw 26]
1.4667 + puts $f $i
1.4668 + close $f
1.4669 + set c [file size $path(test1)]
1.4670 + set f [open $path(test1) r]
1.4671 + fconfigure $f -translation auto -eofchar \x1a
1.4672 + set l [string length [read $f]]
1.4673 + set e [eof $f]
1.4674 + close $f
1.4675 + list $c $l $e
1.4676 +} {17 8 1}
1.4677 +test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} {
1.4678 + file delete $path(test1)
1.4679 + set f [open $path(test1) w]
1.4680 + fconfigure $f -translation cr -eofchar {}
1.4681 + set i [format abc\ndef\n%cqrs\nuvw 26]
1.4682 + puts $f $i
1.4683 + close $f
1.4684 + set c [file size $path(test1)]
1.4685 + set f [open $path(test1) r]
1.4686 + fconfigure $f -translation cr -eofchar \x1a
1.4687 + set l [string length [read $f]]
1.4688 + set e [eof $f]
1.4689 + close $f
1.4690 + list $c $l $e
1.4691 +} {17 8 1}
1.4692 +test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} {
1.4693 + file delete $path(test1)
1.4694 + set f [open $path(test1) w]
1.4695 + fconfigure $f -translation crlf -eofchar {}
1.4696 + set i [format abc\ndef\n%cqrs\nuvw 26]
1.4697 + puts $f $i
1.4698 + close $f
1.4699 + set c [file size $path(test1)]
1.4700 + set f [open $path(test1) r]
1.4701 + fconfigure $f -translation auto -eofchar \x1a
1.4702 + set l [string length [read $f]]
1.4703 + set e [eof $f]
1.4704 + close $f
1.4705 + list $c $l $e
1.4706 +} {21 8 1}
1.4707 +test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} {
1.4708 + file delete $path(test1)
1.4709 + set f [open $path(test1) w]
1.4710 + fconfigure $f -translation crlf -eofchar {}
1.4711 + set i [format abc\ndef\n%cqrs\nuvw 26]
1.4712 + puts $f $i
1.4713 + close $f
1.4714 + set c [file size $path(test1)]
1.4715 + set f [open $path(test1) r]
1.4716 + fconfigure $f -translation crlf -eofchar \x1a
1.4717 + set l [string length [read $f]]
1.4718 + set e [eof $f]
1.4719 + close $f
1.4720 + list $c $l $e
1.4721 +} {21 8 1}
1.4722 +
1.4723 +# Test Tcl_InputBlocked
1.4724 +
1.4725 +test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} {
1.4726 + set f1 [open "|[list [interpreter]]" r+]
1.4727 + puts $f1 {puts hello_from_pipe}
1.4728 + flush $f1
1.4729 + gets $f1
1.4730 + fconfigure $f1 -blocking off -buffering full
1.4731 + puts $f1 {puts hello}
1.4732 + set x ""
1.4733 + lappend x [gets $f1]
1.4734 + lappend x [fblocked $f1]
1.4735 + flush $f1
1.4736 + after 200
1.4737 + lappend x [gets $f1]
1.4738 + lappend x [fblocked $f1]
1.4739 + lappend x [gets $f1]
1.4740 + lappend x [fblocked $f1]
1.4741 + close $f1
1.4742 + set x
1.4743 +} {{} 1 hello 0 {} 1}
1.4744 +test io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio openpipe} {
1.4745 + set f1 [open "|[list [interpreter]]" r+]
1.4746 + fconfigure $f1 -buffering line
1.4747 + puts $f1 {puts hello_from_pipe}
1.4748 + set x ""
1.4749 + lappend x [gets $f1]
1.4750 + lappend x [fblocked $f1]
1.4751 + puts $f1 {exit}
1.4752 + lappend x [gets $f1]
1.4753 + lappend x [fblocked $f1]
1.4754 + lappend x [eof $f1]
1.4755 + close $f1
1.4756 + set x
1.4757 +} {hello_from_pipe 0 {} 0 1}
1.4758 +test io-36.3 {Tcl_InputBlocked vs files, short read} {
1.4759 + file delete $path(test1)
1.4760 + set f [open $path(test1) w]
1.4761 + puts $f abcdefghijklmnop
1.4762 + close $f
1.4763 + set f [open $path(test1) r]
1.4764 + set l ""
1.4765 + lappend l [fblocked $f]
1.4766 + lappend l [read $f 3]
1.4767 + lappend l [fblocked $f]
1.4768 + lappend l [read -nonewline $f]
1.4769 + lappend l [fblocked $f]
1.4770 + lappend l [eof $f]
1.4771 + close $f
1.4772 + set l
1.4773 +} {0 abc 0 defghijklmnop 0 1}
1.4774 +test io-36.4 {Tcl_InputBlocked vs files, event driven read} {fileevent} {
1.4775 + proc in {f} {
1.4776 + variable l
1.4777 + variable x
1.4778 + lappend l [read $f 3]
1.4779 + if {[eof $f]} {lappend l eof; close $f; set x done}
1.4780 + }
1.4781 + file delete $path(test1)
1.4782 + set f [open $path(test1) w]
1.4783 + puts $f abcdefghijklmnop
1.4784 + close $f
1.4785 + set f [open $path(test1) r]
1.4786 + set l ""
1.4787 + fileevent $f readable [namespace code [list in $f]]
1.4788 + variable x
1.4789 + vwait [namespace which -variable x]
1.4790 + set l
1.4791 +} {abc def ghi jkl mno {p
1.4792 +} eof}
1.4793 +test io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} {
1.4794 + file delete $path(test1)
1.4795 + set f [open $path(test1) w]
1.4796 + puts $f abcdefghijklmnop
1.4797 + close $f
1.4798 + set f [open $path(test1) r]
1.4799 + fconfigure $f -blocking off
1.4800 + set l ""
1.4801 + lappend l [fblocked $f]
1.4802 + lappend l [read $f 3]
1.4803 + lappend l [fblocked $f]
1.4804 + lappend l [read -nonewline $f]
1.4805 + lappend l [fblocked $f]
1.4806 + lappend l [eof $f]
1.4807 + close $f
1.4808 + set l
1.4809 +} {0 abc 0 defghijklmnop 0 1}
1.4810 +test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles fileevent} {
1.4811 + proc in {f} {
1.4812 + variable l
1.4813 + variable x
1.4814 + lappend l [read $f 3]
1.4815 + if {[eof $f]} {lappend l eof; close $f; set x done}
1.4816 + }
1.4817 + file delete $path(test1)
1.4818 + set f [open $path(test1) w]
1.4819 + puts $f abcdefghijklmnop
1.4820 + close $f
1.4821 + set f [open $path(test1) r]
1.4822 + fconfigure $f -blocking off
1.4823 + set l ""
1.4824 + fileevent $f readable [namespace code [list in $f]]
1.4825 + variable x
1.4826 + vwait [namespace which -variable x]
1.4827 + set l
1.4828 +} {abc def ghi jkl mno {p
1.4829 +} eof}
1.4830 +
1.4831 +# Test Tcl_InputBuffered
1.4832 +
1.4833 +test io-37.1 {Tcl_InputBuffered} {testchannel} {
1.4834 + set f [open $path(longfile) r]
1.4835 + fconfigure $f -buffersize 4096
1.4836 + read $f 3
1.4837 + set l ""
1.4838 + lappend l [testchannel inputbuffered $f]
1.4839 + lappend l [tell $f]
1.4840 + close $f
1.4841 + set l
1.4842 +} {4093 3}
1.4843 +test io-37.2 {Tcl_InputBuffered, test input flushing on seek} {testchannel} {
1.4844 + set f [open $path(longfile) r]
1.4845 + fconfigure $f -buffersize 4096
1.4846 + read $f 3
1.4847 + set l ""
1.4848 + lappend l [testchannel inputbuffered $f]
1.4849 + lappend l [tell $f]
1.4850 + seek $f 0 current
1.4851 + lappend l [testchannel inputbuffered $f]
1.4852 + lappend l [tell $f]
1.4853 + close $f
1.4854 + set l
1.4855 +} {4093 3 0 3}
1.4856 +
1.4857 +# Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize
1.4858 +
1.4859 +test io-38.1 {Tcl_GetChannelBufferSize, default buffer size} {
1.4860 + set f [open $path(longfile) r]
1.4861 + set s [fconfigure $f -buffersize]
1.4862 + close $f
1.4863 + set s
1.4864 +} 4096
1.4865 +test io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} {
1.4866 + set f [open $path(longfile) r]
1.4867 + set l ""
1.4868 + lappend l [fconfigure $f -buffersize]
1.4869 + fconfigure $f -buffersize 10000
1.4870 + lappend l [fconfigure $f -buffersize]
1.4871 + fconfigure $f -buffersize 1
1.4872 + lappend l [fconfigure $f -buffersize]
1.4873 + fconfigure $f -buffersize -1
1.4874 + lappend l [fconfigure $f -buffersize]
1.4875 + fconfigure $f -buffersize 0
1.4876 + lappend l [fconfigure $f -buffersize]
1.4877 + fconfigure $f -buffersize 100000
1.4878 + lappend l [fconfigure $f -buffersize]
1.4879 + fconfigure $f -buffersize 10000000
1.4880 + lappend l [fconfigure $f -buffersize]
1.4881 + close $f
1.4882 + set l
1.4883 +} {4096 10000 1 1 1 100000 100000}
1.4884 +
1.4885 +test io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} {
1.4886 + # This test crashes the interp if Bug #427196 is not fixed
1.4887 +
1.4888 + set chan [open [info script] r]
1.4889 + fconfigure $chan -buffersize 10
1.4890 + set var [read $chan 2]
1.4891 + fconfigure $chan -buffersize 32
1.4892 + append var [read $chan]
1.4893 + close $chan
1.4894 +} {}
1.4895 +
1.4896 +# Test Tcl_SetChannelOption, Tcl_GetChannelOption
1.4897 +
1.4898 +test io-39.1 {Tcl_GetChannelOption} {
1.4899 + file delete $path(test1)
1.4900 + set f1 [open $path(test1) w]
1.4901 + set x [fconfigure $f1 -blocking]
1.4902 + close $f1
1.4903 + set x
1.4904 +} 1
1.4905 +#
1.4906 +# Test 17.2 was removed.
1.4907 +#
1.4908 +test io-39.2 {Tcl_GetChannelOption} {
1.4909 + file delete $path(test1)
1.4910 + set f1 [open $path(test1) w]
1.4911 + set x [fconfigure $f1 -buffering]
1.4912 + close $f1
1.4913 + set x
1.4914 +} full
1.4915 +test io-39.3 {Tcl_GetChannelOption} {
1.4916 + file delete $path(test1)
1.4917 + set f1 [open $path(test1) w]
1.4918 + fconfigure $f1 -buffering line
1.4919 + set x [fconfigure $f1 -buffering]
1.4920 + close $f1
1.4921 + set x
1.4922 +} line
1.4923 +test io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} {
1.4924 + file delete $path(test1)
1.4925 + set f1 [open $path(test1) w]
1.4926 + set l ""
1.4927 + lappend l [fconfigure $f1 -buffering]
1.4928 + fconfigure $f1 -buffering line
1.4929 + lappend l [fconfigure $f1 -buffering]
1.4930 + fconfigure $f1 -buffering none
1.4931 + lappend l [fconfigure $f1 -buffering]
1.4932 + fconfigure $f1 -buffering line
1.4933 + lappend l [fconfigure $f1 -buffering]
1.4934 + fconfigure $f1 -buffering full
1.4935 + lappend l [fconfigure $f1 -buffering]
1.4936 + close $f1
1.4937 + set l
1.4938 +} {full line none line full}
1.4939 +test io-39.5 {Tcl_GetChannelOption, invariance} {
1.4940 + file delete $path(test1)
1.4941 + set f1 [open $path(test1) w]
1.4942 + set l ""
1.4943 + lappend l [fconfigure $f1 -buffering]
1.4944 + lappend l [list [catch {fconfigure $f1 -buffering green} msg] $msg]
1.4945 + lappend l [fconfigure $f1 -buffering]
1.4946 + close $f1
1.4947 + set l
1.4948 +} {full {1 {bad value for -buffering: must be one of full, line, or none}} full}
1.4949 +test io-39.6 {Tcl_SetChannelOption, multiple options} {
1.4950 + file delete $path(test1)
1.4951 + set f1 [open $path(test1) w]
1.4952 + fconfigure $f1 -translation lf -buffering line
1.4953 + puts $f1 hello
1.4954 + puts $f1 bye
1.4955 + set x [file size $path(test1)]
1.4956 + close $f1
1.4957 + set x
1.4958 +} 10
1.4959 +test io-39.7 {Tcl_SetChannelOption, buffering, translation} {
1.4960 + file delete $path(test1)
1.4961 + set f1 [open $path(test1) w]
1.4962 + fconfigure $f1 -translation lf
1.4963 + puts $f1 hello
1.4964 + puts $f1 bye
1.4965 + set x ""
1.4966 + fconfigure $f1 -buffering line
1.4967 + lappend x [file size $path(test1)]
1.4968 + puts $f1 really_bye
1.4969 + lappend x [file size $path(test1)]
1.4970 + close $f1
1.4971 + set x
1.4972 +} {0 21}
1.4973 +test io-39.8 {Tcl_SetChannelOption, different buffering options} {
1.4974 + file delete $path(test1)
1.4975 + set f1 [open $path(test1) w]
1.4976 + set l ""
1.4977 + fconfigure $f1 -translation lf -buffering none -eofchar {}
1.4978 + puts -nonewline $f1 hello
1.4979 + lappend l [file size $path(test1)]
1.4980 + puts -nonewline $f1 hello
1.4981 + lappend l [file size $path(test1)]
1.4982 + fconfigure $f1 -buffering full
1.4983 + puts -nonewline $f1 hello
1.4984 + lappend l [file size $path(test1)]
1.4985 + fconfigure $f1 -buffering none
1.4986 + lappend l [file size $path(test1)]
1.4987 + puts -nonewline $f1 hello
1.4988 + lappend l [file size $path(test1)]
1.4989 + close $f1
1.4990 + lappend l [file size $path(test1)]
1.4991 + set l
1.4992 +} {5 10 10 10 20 20}
1.4993 +test io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} {
1.4994 + file delete $path(test1)
1.4995 + set f1 [open $path(test1) w]
1.4996 + close $f1
1.4997 + set f1 [open $path(test1) r]
1.4998 + set x ""
1.4999 + lappend x [fconfigure $f1 -blocking]
1.5000 + fconfigure $f1 -blocking off
1.5001 + lappend x [fconfigure $f1 -blocking]
1.5002 + lappend x [gets $f1]
1.5003 + lappend x [read $f1 1000]
1.5004 + lappend x [fblocked $f1]
1.5005 + lappend x [eof $f1]
1.5006 + close $f1
1.5007 + set x
1.5008 +} {1 0 {} {} 0 1}
1.5009 +test io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} {
1.5010 + file delete $path(pipe)
1.5011 + set f1 [open $path(pipe) w]
1.5012 + puts $f1 {
1.5013 + gets stdin
1.5014 + after 100
1.5015 + puts hi
1.5016 + gets stdin
1.5017 + }
1.5018 + close $f1
1.5019 + set x ""
1.5020 + set f1 [open "|[list [interpreter] $path(pipe)]" r+]
1.5021 + fconfigure $f1 -blocking off -buffering line
1.5022 + lappend x [fconfigure $f1 -blocking]
1.5023 + lappend x [gets $f1]
1.5024 + lappend x [fblocked $f1]
1.5025 + fconfigure $f1 -blocking on
1.5026 + puts $f1 hello
1.5027 + fconfigure $f1 -blocking off
1.5028 + lappend x [gets $f1]
1.5029 + lappend x [fblocked $f1]
1.5030 + fconfigure $f1 -blocking on
1.5031 + puts $f1 bye
1.5032 + fconfigure $f1 -blocking off
1.5033 + lappend x [gets $f1]
1.5034 + lappend x [fblocked $f1]
1.5035 + fconfigure $f1 -blocking on
1.5036 + lappend x [fconfigure $f1 -blocking]
1.5037 + lappend x [gets $f1]
1.5038 + lappend x [fblocked $f1]
1.5039 + lappend x [eof $f1]
1.5040 + lappend x [gets $f1]
1.5041 + lappend x [eof $f1]
1.5042 + close $f1
1.5043 + set x
1.5044 +} {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1}
1.5045 +test io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} {
1.5046 + file delete $path(test1)
1.5047 + set f [open $path(test1) w]
1.5048 + fconfigure $f -buffersize -10
1.5049 + set x [fconfigure $f -buffersize]
1.5050 + close $f
1.5051 + set x
1.5052 +} 4096
1.5053 +test io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size} {
1.5054 + file delete $path(test1)
1.5055 + set f [open $path(test1) w]
1.5056 + fconfigure $f -buffersize 10000000
1.5057 + set x [fconfigure $f -buffersize]
1.5058 + close $f
1.5059 + set x
1.5060 +} 4096
1.5061 +test io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} {
1.5062 + file delete $path(test1)
1.5063 + set f [open $path(test1) w]
1.5064 + fconfigure $f -buffersize 40000
1.5065 + set x [fconfigure $f -buffersize]
1.5066 + close $f
1.5067 + set x
1.5068 +} 40000
1.5069 +test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
1.5070 + file delete $path(test1)
1.5071 + set f [open $path(test1) w]
1.5072 + fconfigure $f -encoding {}
1.5073 + puts -nonewline $f \xe7\x89\xa6
1.5074 + close $f
1.5075 + set f [open $path(test1) r]
1.5076 + fconfigure $f -encoding utf-8
1.5077 + set x [read $f]
1.5078 + close $f
1.5079 + set x
1.5080 +} \u7266
1.5081 +test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
1.5082 + file delete $path(test1)
1.5083 + set f [open $path(test1) w]
1.5084 + fconfigure $f -encoding binary
1.5085 + puts -nonewline $f \xe7\x89\xa6
1.5086 + close $f
1.5087 + set f [open $path(test1) r]
1.5088 + fconfigure $f -encoding utf-8
1.5089 + set x [read $f]
1.5090 + close $f
1.5091 + set x
1.5092 +} \u7266
1.5093 +test io-39.16 {Tcl_SetChannelOption: -encoding, errors} {
1.5094 + file delete $path(test1)
1.5095 + set f [open $path(test1) w]
1.5096 + set result [list [catch {fconfigure $f -encoding foobar} msg] $msg]
1.5097 + close $f
1.5098 + set result
1.5099 +} {1 {unknown encoding "foobar"}}
1.5100 +test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio openpipe fileevent} {
1.5101 + set f [open "|[list [interpreter] $path(cat)]" r+]
1.5102 + fconfigure $f -encoding binary
1.5103 + puts -nonewline $f "\xe7"
1.5104 + flush $f
1.5105 + fconfigure $f -encoding utf-8 -blocking 0
1.5106 + variable x {}
1.5107 + fileevent $f readable [namespace code { lappend x [read $f] }]
1.5108 + vwait [namespace which -variable x]
1.5109 + after 300 [namespace code { lappend x timeout }]
1.5110 + vwait [namespace which -variable x]
1.5111 + fconfigure $f -encoding utf-8
1.5112 + vwait [namespace which -variable x]
1.5113 + after 300 [namespace code { lappend x timeout }]
1.5114 + vwait [namespace which -variable x]
1.5115 + fconfigure $f -encoding binary
1.5116 + vwait [namespace which -variable x]
1.5117 + after 300 [namespace code { lappend x timeout }]
1.5118 + vwait [namespace which -variable x]
1.5119 + close $f
1.5120 + set x
1.5121 +} "{} timeout {} timeout \xe7 timeout"
1.5122 +
1.5123 +test io-39.18 {Tcl_SetChannelOption, setting read mode independently} \
1.5124 + {socket} {
1.5125 + proc accept {s a p} {close $s}
1.5126 + set s1 [socket -server [namespace code accept] 0]
1.5127 + set port [lindex [fconfigure $s1 -sockname] 2]
1.5128 + set s2 [socket 127.0.0.1 $port]
1.5129 + update
1.5130 + fconfigure $s2 -translation {auto lf}
1.5131 + set modes [fconfigure $s2 -translation]
1.5132 + close $s1
1.5133 + close $s2
1.5134 + set modes
1.5135 +} {auto lf}
1.5136 +test io-39.19 {Tcl_SetChannelOption, setting read mode independently} \
1.5137 + {socket} {
1.5138 + proc accept {s a p} {close $s}
1.5139 + set s1 [socket -server [namespace code accept] 0]
1.5140 + set port [lindex [fconfigure $s1 -sockname] 2]
1.5141 + set s2 [socket 127.0.0.1 $port]
1.5142 + update
1.5143 + fconfigure $s2 -translation {auto crlf}
1.5144 + set modes [fconfigure $s2 -translation]
1.5145 + close $s1
1.5146 + close $s2
1.5147 + set modes
1.5148 +} {auto crlf}
1.5149 +test io-39.20 {Tcl_SetChannelOption, setting read mode independently} \
1.5150 + {socket} {
1.5151 + proc accept {s a p} {close $s}
1.5152 + set s1 [socket -server [namespace code accept] 0]
1.5153 + set port [lindex [fconfigure $s1 -sockname] 2]
1.5154 + set s2 [socket 127.0.0.1 $port]
1.5155 + update
1.5156 + fconfigure $s2 -translation {auto cr}
1.5157 + set modes [fconfigure $s2 -translation]
1.5158 + close $s1
1.5159 + close $s2
1.5160 + set modes
1.5161 +} {auto cr}
1.5162 +test io-39.21 {Tcl_SetChannelOption, setting read mode independently} \
1.5163 + {socket} {
1.5164 + proc accept {s a p} {close $s}
1.5165 + set s1 [socket -server [namespace code accept] 0]
1.5166 + set port [lindex [fconfigure $s1 -sockname] 2]
1.5167 + set s2 [socket 127.0.0.1 $port]
1.5168 + update
1.5169 + fconfigure $s2 -translation {auto auto}
1.5170 + set modes [fconfigure $s2 -translation]
1.5171 + close $s1
1.5172 + close $s2
1.5173 + set modes
1.5174 +} {auto crlf}
1.5175 +
1.5176 +test io-39.22 {Tcl_SetChannelOption, invariance} {unixOnly} {
1.5177 + file delete $path(test1)
1.5178 + set f1 [open $path(test1) w+]
1.5179 + set l ""
1.5180 + lappend l [fconfigure $f1 -eofchar]
1.5181 + fconfigure $f1 -eofchar {ON GO}
1.5182 + lappend l [fconfigure $f1 -eofchar]
1.5183 + fconfigure $f1 -eofchar D
1.5184 + lappend l [fconfigure $f1 -eofchar]
1.5185 + close $f1
1.5186 + set l
1.5187 +} {{{} {}} {O G} {D D}}
1.5188 +
1.5189 +test io-39.22a {Tcl_SetChannelOption, invariance} {
1.5190 + file delete $path(test1)
1.5191 + set f1 [open $path(test1) w+]
1.5192 + set l [list]
1.5193 + fconfigure $f1 -eofchar {ON GO}
1.5194 + lappend l [fconfigure $f1 -eofchar]
1.5195 + fconfigure $f1 -eofchar D
1.5196 + lappend l [fconfigure $f1 -eofchar]
1.5197 + lappend l [list [catch {fconfigure $f1 -eofchar {1 2 3}} msg] $msg]
1.5198 + close $f1
1.5199 + set l
1.5200 +} {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}}
1.5201 +
1.5202 +
1.5203 +test io-39.23 {Tcl_GetChannelOption, server socket is not readable or
1.5204 + writeable, it should still have valid -eofchar and -translation options } {
1.5205 + set l [list]
1.5206 + set sock [socket -server [namespace code accept] 0]
1.5207 + lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
1.5208 + close $sock
1.5209 + set l
1.5210 +} {{{}} auto}
1.5211 +test io-39.24 {Tcl_SetChannelOption, server socket is not readable or
1.5212 + writable so we can't change -eofchar or -translation } {
1.5213 + set l [list]
1.5214 + set sock [socket -server [namespace code accept] 0]
1.5215 + fconfigure $sock -eofchar D -translation lf
1.5216 + lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
1.5217 + close $sock
1.5218 + set l
1.5219 +} {{{}} auto}
1.5220 +
1.5221 +test io-40.1 {POSIX open access modes: RDWR} {
1.5222 + file delete $path(test3)
1.5223 + set f [open $path(test3) w]
1.5224 + puts $f xyzzy
1.5225 + close $f
1.5226 + set f [open $path(test3) RDWR]
1.5227 + puts -nonewline $f "ab"
1.5228 + seek $f 0 current
1.5229 + set x [gets $f]
1.5230 + close $f
1.5231 + set f [open $path(test3) r]
1.5232 + lappend x [gets $f]
1.5233 + close $f
1.5234 + set x
1.5235 +} {zzy abzzy}
1.5236 +test io-40.2 {POSIX open access modes: CREAT} {unixOnly} {
1.5237 + file delete $path(test3)
1.5238 + set f [open $path(test3) {WRONLY CREAT} 0600]
1.5239 + file stat $path(test3) stats
1.5240 + set x [format "0%o" [expr $stats(mode)&0777]]
1.5241 + puts $f "line 1"
1.5242 + close $f
1.5243 + set f [open $path(test3) r]
1.5244 + lappend x [gets $f]
1.5245 + close $f
1.5246 + set x
1.5247 +} {0600 {line 1}}
1.5248 +
1.5249 +# some tests can only be run is umask is 2
1.5250 +# if "umask" cannot be run, the tests will be skipped.
1.5251 +catch {testConstraint umask2 [expr {[exec umask] == 2}]}
1.5252 +
1.5253 +test io-40.3 {POSIX open access modes: CREAT} {unixOnly umask2} {
1.5254 + # This test only works if your umask is 2, like ouster's.
1.5255 + file delete $path(test3)
1.5256 + set f [open $path(test3) {WRONLY CREAT}]
1.5257 + close $f
1.5258 + file stat test3 stats
1.5259 + format "0%o" [expr $stats(mode)&0777]
1.5260 +} 0664
1.5261 +test io-40.4 {POSIX open access modes: CREAT} {
1.5262 + file delete $path(test3)
1.5263 + set f [open $path(test3) w]
1.5264 + fconfigure $f -eofchar {}
1.5265 + puts $f xyzzy
1.5266 + close $f
1.5267 + set f [open $path(test3) {WRONLY CREAT}]
1.5268 + fconfigure $f -eofchar {}
1.5269 + puts -nonewline $f "ab"
1.5270 + close $f
1.5271 + set f [open $path(test3) r]
1.5272 + set x [gets $f]
1.5273 + close $f
1.5274 + set x
1.5275 +} abzzy
1.5276 +test io-40.5 {POSIX open access modes: APPEND} {
1.5277 + file delete $path(test3)
1.5278 + set f [open $path(test3) w]
1.5279 + fconfigure $f -translation lf -eofchar {}
1.5280 + puts $f xyzzy
1.5281 + close $f
1.5282 + set f [open $path(test3) {WRONLY APPEND}]
1.5283 + fconfigure $f -translation lf
1.5284 + puts $f "new line"
1.5285 + seek $f 0
1.5286 + puts $f "abc"
1.5287 + close $f
1.5288 + set f [open $path(test3) r]
1.5289 + fconfigure $f -translation lf
1.5290 + set x ""
1.5291 + seek $f 6 current
1.5292 + lappend x [gets $f]
1.5293 + lappend x [gets $f]
1.5294 + close $f
1.5295 + set x
1.5296 +} {{new line} abc}
1.5297 +test io-40.6 {POSIX open access modes: EXCL} -match regexp -body {
1.5298 + file delete $path(test3)
1.5299 + set f [open $path(test3) w]
1.5300 + puts $f xyzzy
1.5301 + close $f
1.5302 + open $path(test3) {WRONLY CREAT EXCL}
1.5303 +} -returnCodes error -result {(?i)couldn't open ".*test3": file (already )?exists}
1.5304 +test io-40.7 {POSIX open access modes: EXCL} {
1.5305 + file delete $path(test3)
1.5306 + set f [open $path(test3) {WRONLY CREAT EXCL}]
1.5307 + fconfigure $f -eofchar {}
1.5308 + puts $f "A test line"
1.5309 + close $f
1.5310 + viewFile test3
1.5311 +} {A test line}
1.5312 +test io-40.8 {POSIX open access modes: TRUNC} {
1.5313 + file delete $path(test3)
1.5314 + set f [open $path(test3) w]
1.5315 + puts $f xyzzy
1.5316 + close $f
1.5317 + set f [open $path(test3) {WRONLY TRUNC}]
1.5318 + puts $f abc
1.5319 + close $f
1.5320 + set f [open $path(test3) r]
1.5321 + set x [gets $f]
1.5322 + close $f
1.5323 + set x
1.5324 +} abc
1.5325 +test io-40.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} {
1.5326 + file delete $path(test3)
1.5327 + set f [open $path(test3) {WRONLY NONBLOCK CREAT}]
1.5328 + puts $f "NONBLOCK test"
1.5329 + close $f
1.5330 + set f [open $path(test3) r]
1.5331 + set x [gets $f]
1.5332 + close $f
1.5333 + set x
1.5334 +} {NONBLOCK test}
1.5335 +test io-40.10 {POSIX open access modes: RDONLY} {
1.5336 + set f [open $path(test1) w]
1.5337 + puts $f "two lines: this one"
1.5338 + puts $f "and this"
1.5339 + close $f
1.5340 + set f [open $path(test1) RDONLY]
1.5341 + set x [list [gets $f] [catch {puts $f Test} msg] $msg]
1.5342 + close $f
1.5343 + string compare [string tolower $x] \
1.5344 + [list {two lines: this one} 1 \
1.5345 + [format "channel \"%s\" wasn't opened for writing" $f]]
1.5346 +} 0
1.5347 +test io-40.11 {POSIX open access modes: RDONLY} -match regexp -body {
1.5348 + file delete $path(test3)
1.5349 + open $path(test3) RDONLY
1.5350 +} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
1.5351 +test io-40.12 {POSIX open access modes: WRONLY} -match regexp -body {
1.5352 + file delete $path(test3)
1.5353 + open $path(test3) WRONLY
1.5354 +} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
1.5355 +test io-40.13 {POSIX open access modes: WRONLY} {
1.5356 + makeFile xyzzy test3
1.5357 + set f [open $path(test3) WRONLY]
1.5358 + fconfigure $f -eofchar {}
1.5359 + puts -nonewline $f "ab"
1.5360 + seek $f 0 current
1.5361 + set x [list [catch {gets $f} msg] $msg]
1.5362 + close $f
1.5363 + lappend x [viewFile test3]
1.5364 + string compare [string tolower $x] \
1.5365 + [list 1 "channel \"$f\" wasn't opened for reading" abzzy]
1.5366 +} 0
1.5367 +test io-40.14 {POSIX open access modes: RDWR} -match regexp -body {
1.5368 + file delete $path(test3)
1.5369 + open $path(test3) RDWR
1.5370 +} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
1.5371 +test io-40.15 {POSIX open access modes: RDWR} {
1.5372 + makeFile xyzzy test3
1.5373 + set f [open $path(test3) RDWR]
1.5374 + puts -nonewline $f "ab"
1.5375 + seek $f 0 current
1.5376 + set x [gets $f]
1.5377 + close $f
1.5378 + lappend x [viewFile test3]
1.5379 +} {zzy abzzy}
1.5380 +if {![file exists ~/_test_] && [file writable ~]} {
1.5381 + test io-40.16 {tilde substitution in open} -setup {
1.5382 + makeFile {Some text} _test_ ~
1.5383 + } -body {
1.5384 + file exists [file join $env(HOME) _test_]
1.5385 + } -cleanup {
1.5386 + removeFile _test_ ~
1.5387 + } -result 1
1.5388 +}
1.5389 +test io-40.17 {tilde substitution in open} {
1.5390 + set home $env(HOME)
1.5391 + unset env(HOME)
1.5392 + set x [list [catch {open ~/foo} msg] $msg]
1.5393 + set env(HOME) $home
1.5394 + set x
1.5395 +} {1 {couldn't find HOME environment variable to expand path}}
1.5396 +
1.5397 +test io-41.1 {Tcl_FileeventCmd: errors} {fileevent} {
1.5398 + list [catch {fileevent foo} msg] $msg
1.5399 +} {1 {wrong # args: should be "fileevent channelId event ?script?"}}
1.5400 +test io-41.2 {Tcl_FileeventCmd: errors} {fileevent} {
1.5401 + list [catch {fileevent foo bar baz q} msg] $msg
1.5402 +} {1 {wrong # args: should be "fileevent channelId event ?script?"}}
1.5403 +test io-41.3 {Tcl_FileeventCmd: errors} {fileevent} {
1.5404 + list [catch {fileevent gorp readable} msg] $msg
1.5405 +} {1 {can not find channel named "gorp"}}
1.5406 +test io-41.4 {Tcl_FileeventCmd: errors} {fileevent} {
1.5407 + list [catch {fileevent gorp writable} msg] $msg
1.5408 +} {1 {can not find channel named "gorp"}}
1.5409 +test io-41.5 {Tcl_FileeventCmd: errors} {fileevent} {
1.5410 + list [catch {fileevent gorp who-knows} msg] $msg
1.5411 +} {1 {bad event name "who-knows": must be readable or writable}}
1.5412 +
1.5413 +#
1.5414 +# Test fileevent on a file
1.5415 +#
1.5416 +
1.5417 +set path(foo) [makeFile {} foo]
1.5418 +set f [open $path(foo) w+]
1.5419 +
1.5420 +test io-42.1 {Tcl_FileeventCmd: creating, deleting, querying} {fileevent} {
1.5421 + list [fileevent $f readable] [fileevent $f writable]
1.5422 +} {{} {}}
1.5423 +test io-42.2 {Tcl_FileeventCmd: replacing} {fileevent} {
1.5424 + set result {}
1.5425 + fileevent $f r "first script"
1.5426 + lappend result [fileevent $f readable]
1.5427 + fileevent $f r "new script"
1.5428 + lappend result [fileevent $f readable]
1.5429 + fileevent $f r "yet another"
1.5430 + lappend result [fileevent $f readable]
1.5431 + fileevent $f r ""
1.5432 + lappend result [fileevent $f readable]
1.5433 +} {{first script} {new script} {yet another} {}}
1.5434 +test io-42.3 {Tcl_FileeventCmd: replacing, with NULL chars in script} {fileevent} {
1.5435 + set result {}
1.5436 + fileevent $f r "first scr\0ipt"
1.5437 + lappend result [string length [fileevent $f readable]]
1.5438 + fileevent $f r "new scr\0ipt"
1.5439 + lappend result [string length [fileevent $f readable]]
1.5440 + fileevent $f r "yet ano\0ther"
1.5441 + lappend result [string length [fileevent $f readable]]
1.5442 + fileevent $f r ""
1.5443 + lappend result [fileevent $f readable]
1.5444 +} {13 11 12 {}}
1.5445 +
1.5446 +test io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixExecs fileevent} {
1.5447 + set result {}
1.5448 + fileevent $f readable "script 1"
1.5449 + lappend result [fileevent $f readable] [fileevent $f writable]
1.5450 + fileevent $f writable "write script"
1.5451 + lappend result [fileevent $f readable] [fileevent $f writable]
1.5452 + fileevent $f readable {}
1.5453 + lappend result [fileevent $f readable] [fileevent $f writable]
1.5454 + fileevent $f writable {}
1.5455 + lappend result [fileevent $f readable] [fileevent $f writable]
1.5456 +} {{script 1} {} {script 1} {write script} {} {write script} {} {}}
1.5457 +test io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup {
1.5458 + set f2 [open "|[list cat -u]" r+]
1.5459 + set f3 [open "|[list cat -u]" r+]
1.5460 +} -constraints {stdio unixExecs fileevent openpipe} -body {
1.5461 + set result {}
1.5462 + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
1.5463 + fileevent $f r "read f"
1.5464 + fileevent $f2 r "read f2"
1.5465 + fileevent $f3 r "read f3"
1.5466 + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
1.5467 + fileevent $f2 r {}
1.5468 + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
1.5469 + fileevent $f3 r {}
1.5470 + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
1.5471 + fileevent $f r {}
1.5472 + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
1.5473 +} -cleanup {
1.5474 + catch {close $f2}
1.5475 + catch {close $f3}
1.5476 +} -result {{} {} {} {read f} {read f2} {read f3} {read f} {} {read f3} {read f} {} {} {} {} {}}
1.5477 +
1.5478 +test io-44.1 {FileEventProc procedure: normal read event} -setup {
1.5479 + set f2 [open "|[list cat -u]" r+]
1.5480 + set f3 [open "|[list cat -u]" r+]
1.5481 +} -constraints {stdio unixExecs fileevent openpipe} -body {
1.5482 + fileevent $f2 readable [namespace code {
1.5483 + set x [gets $f2]; fileevent $f2 readable {}
1.5484 + }]
1.5485 + puts $f2 text; flush $f2
1.5486 + variable x initial
1.5487 + vwait [namespace which -variable x]
1.5488 + set x
1.5489 +} -cleanup {
1.5490 + catch {close $f2}
1.5491 + catch {close $f3}
1.5492 +} -result {text}
1.5493 +test io-44.2 {FileEventProc procedure: error in read event} -setup {
1.5494 + set f2 [open "|[list cat -u]" r+]
1.5495 + set f3 [open "|[list cat -u]" r+]
1.5496 +} -constraints {stdio unixExecs fileevent openpipe} -body {
1.5497 + proc ::bgerror args "set [namespace which -variable x] \$args"
1.5498 + fileevent $f2 readable {error bogus}
1.5499 + puts $f2 text; flush $f2
1.5500 + variable x initial
1.5501 + vwait [namespace which -variable x]
1.5502 + rename ::bgerror {}
1.5503 + list $x [fileevent $f2 readable]
1.5504 +} -cleanup {
1.5505 + catch {close $f2}
1.5506 + catch {close $f3}
1.5507 +} -result {bogus {}}
1.5508 +test io-44.3 {FileEventProc procedure: normal write event} -setup {
1.5509 + set f2 [open "|[list cat -u]" r+]
1.5510 + set f3 [open "|[list cat -u]" r+]
1.5511 +} -constraints {stdio unixExecs fileevent openpipe} -body {
1.5512 + fileevent $f2 writable [namespace code {
1.5513 + lappend x "triggered"
1.5514 + incr count -1
1.5515 + if {$count <= 0} {
1.5516 + fileevent $f2 writable {}
1.5517 + }
1.5518 + }]
1.5519 + variable x initial
1.5520 + set count 3
1.5521 + vwait [namespace which -variable x]
1.5522 + vwait [namespace which -variable x]
1.5523 + vwait [namespace which -variable x]
1.5524 + set x
1.5525 +} -cleanup {
1.5526 + catch {close $f2}
1.5527 + catch {close $f3}
1.5528 +} -result {initial triggered triggered triggered}
1.5529 +test io-44.4 {FileEventProc procedure: eror in write event} -setup {
1.5530 + set f2 [open "|[list cat -u]" r+]
1.5531 + set f3 [open "|[list cat -u]" r+]
1.5532 +} -constraints {stdio unixExecs fileevent openpipe} -body {
1.5533 + proc ::bgerror args "set [namespace which -variable x] \$args"
1.5534 + fileevent $f2 writable {error bad-write}
1.5535 + variable x initial
1.5536 + vwait [namespace which -variable x]
1.5537 + rename ::bgerror {}
1.5538 + list $x [fileevent $f2 writable]
1.5539 +} -cleanup {
1.5540 + catch {close $f2}
1.5541 + catch {close $f3}
1.5542 +} -result {bad-write {}}
1.5543 +test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fileevent} {
1.5544 + set f4 [open "|[list [interpreter] $path(cat) << foo]" r]
1.5545 + fileevent $f4 readable [namespace code {
1.5546 + if {[gets $f4 line] < 0} {
1.5547 + lappend x eof
1.5548 + fileevent $f4 readable {}
1.5549 + } else {
1.5550 + lappend x $line
1.5551 + }
1.5552 + }]
1.5553 + variable x initial
1.5554 + vwait [namespace which -variable x]
1.5555 + vwait [namespace which -variable x]
1.5556 + close $f4
1.5557 + set x
1.5558 +} {initial foo eof}
1.5559 +
1.5560 +
1.5561 +close $f
1.5562 +makeFile "foo bar" foo
1.5563 +test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} {
1.5564 + set f [open $path(foo) r]
1.5565 + fileevent $f readable [namespace code {
1.5566 + lappend x "binding triggered: \"[gets $f]\""
1.5567 + fileevent $f readable {}
1.5568 + }]
1.5569 + close $f
1.5570 + set x initial
1.5571 + after 100 [namespace code { set y done }]
1.5572 + variable y
1.5573 + vwait [namespace which -variable y]
1.5574 + set x
1.5575 +} {initial}
1.5576 +test io-45.2 {DeleteFileEvent, cleanup on close} {fileevent} {
1.5577 + set f [open $path(foo) r]
1.5578 + set f2 [open $path(foo) r]
1.5579 + fileevent $f readable [namespace code {
1.5580 + lappend x "f triggered: \"[gets $f]\""
1.5581 + fileevent $f readable {}
1.5582 + }]
1.5583 + fileevent $f2 readable [namespace code {
1.5584 + lappend x "f2 triggered: \"[gets $f2]\""
1.5585 + fileevent $f2 readable {}
1.5586 + }]
1.5587 + close $f
1.5588 + variable x initial
1.5589 + vwait [namespace which -variable x]
1.5590 + close $f2
1.5591 + set x
1.5592 +} {initial {f2 triggered: "foo bar"}}
1.5593 +test io-45.3 {DeleteFileEvent, cleanup on close} {fileevent} {
1.5594 + set f [open $path(foo) r]
1.5595 + set f2 [open $path(foo) r]
1.5596 + set f3 [open $path(foo) r]
1.5597 + fileevent $f readable {f script}
1.5598 + fileevent $f2 readable {f2 script}
1.5599 + fileevent $f3 readable {f3 script}
1.5600 + set x {}
1.5601 + close $f2
1.5602 + lappend x [catch {fileevent $f readable} msg] $msg \
1.5603 + [catch {fileevent $f2 readable}] \
1.5604 + [catch {fileevent $f3 readable} msg] $msg
1.5605 + close $f3
1.5606 + lappend x [catch {fileevent $f readable} msg] $msg \
1.5607 + [catch {fileevent $f2 readable}] \
1.5608 + [catch {fileevent $f3 readable}]
1.5609 + close $f
1.5610 + lappend x [catch {fileevent $f readable}] \
1.5611 + [catch {fileevent $f2 readable}] \
1.5612 + [catch {fileevent $f3 readable}]
1.5613 +} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1}
1.5614 +
1.5615 +# Execute these tests only if the "testfevent" command is present.
1.5616 +testConstraint testfevent [llength [info commands testfevent]]
1.5617 +
1.5618 +test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} {
1.5619 + testfevent create
1.5620 + set script "set f \[[list open $path(foo) r]]\n"
1.5621 + append script {
1.5622 + set x "no event"
1.5623 + fileevent $f readable [namespace code {
1.5624 + set x "f triggered: [gets $f]"
1.5625 + fileevent $f readable {}
1.5626 + }]
1.5627 + }
1.5628 + testfevent cmd $script
1.5629 + after 1 ;# We must delay because Windows takes a little time to notice
1.5630 + update
1.5631 + testfevent cmd {close $f}
1.5632 + list [testfevent cmd {set x}] [testfevent cmd {info commands after}]
1.5633 +} {{f triggered: foo bar} after}
1.5634 +test io-46.2 {Tcl event loop vs multiple interpreters} testfevent {
1.5635 + testfevent create
1.5636 + testfevent cmd {
1.5637 + variable x 0
1.5638 + after 100 {set x triggered}
1.5639 + vwait [namespace which -variable x]
1.5640 + set x
1.5641 + }
1.5642 +} {triggered}
1.5643 +test io-46.3 {Tcl event loop vs multiple interpreters} testfevent {
1.5644 + testfevent create
1.5645 + testfevent cmd {
1.5646 + set x 0
1.5647 + after 10 {lappend x timer}
1.5648 + after 30
1.5649 + set result $x
1.5650 + update idletasks
1.5651 + lappend result $x
1.5652 + update
1.5653 + lappend result $x
1.5654 + }
1.5655 +} {0 0 {0 timer}}
1.5656 +
1.5657 +test io-47.1 {fileevent vs multiple interpreters} {testfevent fileevent} {
1.5658 + set f [open $path(foo) r]
1.5659 + set f2 [open $path(foo) r]
1.5660 + set f3 [open $path(foo) r]
1.5661 + fileevent $f readable {script 1}
1.5662 + testfevent create
1.5663 + testfevent share $f2
1.5664 + testfevent cmd "fileevent $f2 readable {script 2}"
1.5665 + fileevent $f3 readable {sript 3}
1.5666 + set x {}
1.5667 + lappend x [fileevent $f2 readable]
1.5668 + testfevent delete
1.5669 + lappend x [fileevent $f readable] [fileevent $f2 readable] \
1.5670 + [fileevent $f3 readable]
1.5671 + close $f
1.5672 + close $f2
1.5673 + close $f3
1.5674 + set x
1.5675 +} {{} {script 1} {} {sript 3}}
1.5676 +test io-47.2 {deleting fileevent on interpreter delete} {testfevent fileevent} {
1.5677 + set f [open $path(foo) r]
1.5678 + set f2 [open $path(foo) r]
1.5679 + set f3 [open $path(foo) r]
1.5680 + set f4 [open $path(foo) r]
1.5681 + fileevent $f readable {script 1}
1.5682 + testfevent create
1.5683 + testfevent share $f2
1.5684 + testfevent share $f3
1.5685 + testfevent cmd "fileevent $f2 readable {script 2}
1.5686 + fileevent $f3 readable {script 3}"
1.5687 + fileevent $f4 readable {script 4}
1.5688 + testfevent delete
1.5689 + set x [list [fileevent $f readable] [fileevent $f2 readable] \
1.5690 + [fileevent $f3 readable] [fileevent $f4 readable]]
1.5691 + close $f
1.5692 + close $f2
1.5693 + close $f3
1.5694 + close $f4
1.5695 + set x
1.5696 +} {{script 1} {} {} {script 4}}
1.5697 +test io-47.3 {deleting fileevent on interpreter delete} {testfevent fileevent} {
1.5698 + set f [open $path(foo) r]
1.5699 + set f2 [open $path(foo) r]
1.5700 + set f3 [open $path(foo) r]
1.5701 + set f4 [open $path(foo) r]
1.5702 + testfevent create
1.5703 + testfevent share $f3
1.5704 + testfevent share $f4
1.5705 + fileevent $f readable {script 1}
1.5706 + fileevent $f2 readable {script 2}
1.5707 + testfevent cmd "fileevent $f3 readable {script 3}
1.5708 + fileevent $f4 readable {script 4}"
1.5709 + testfevent delete
1.5710 + set x [list [fileevent $f readable] [fileevent $f2 readable] \
1.5711 + [fileevent $f3 readable] [fileevent $f4 readable]]
1.5712 + close $f
1.5713 + close $f2
1.5714 + close $f3
1.5715 + close $f4
1.5716 + set x
1.5717 +} {{script 1} {script 2} {} {}}
1.5718 +test io-47.4 {file events on shared files and multiple interpreters} {testfevent fileevent} {
1.5719 + set f [open $path(foo) r]
1.5720 + set f2 [open $path(foo) r]
1.5721 + testfevent create
1.5722 + testfevent share $f
1.5723 + testfevent cmd "fileevent $f readable {script 1}"
1.5724 + fileevent $f readable {script 2}
1.5725 + fileevent $f2 readable {script 3}
1.5726 + set x [list [fileevent $f2 readable] \
1.5727 + [testfevent cmd "fileevent $f readable"] \
1.5728 + [fileevent $f readable]]
1.5729 + testfevent delete
1.5730 + close $f
1.5731 + close $f2
1.5732 + set x
1.5733 +} {{script 3} {script 1} {script 2}}
1.5734 +test io-47.5 {file events on shared files, deleting file events} {testfevent fileevent} {
1.5735 + set f [open $path(foo) r]
1.5736 + testfevent create
1.5737 + testfevent share $f
1.5738 + testfevent cmd "fileevent $f readable {script 1}"
1.5739 + fileevent $f readable {script 2}
1.5740 + testfevent cmd "fileevent $f readable {}"
1.5741 + set x [list [testfevent cmd "fileevent $f readable"] \
1.5742 + [fileevent $f readable]]
1.5743 + testfevent delete
1.5744 + close $f
1.5745 + set x
1.5746 +} {{} {script 2}}
1.5747 +test io-47.6 {file events on shared files, deleting file events} {testfevent fileevent} {
1.5748 + set f [open $path(foo) r]
1.5749 + testfevent create
1.5750 + testfevent share $f
1.5751 + testfevent cmd "fileevent $f readable {script 1}"
1.5752 + fileevent $f readable {script 2}
1.5753 + fileevent $f readable {}
1.5754 + set x [list [testfevent cmd "fileevent $f readable"] \
1.5755 + [fileevent $f readable]]
1.5756 + testfevent delete
1.5757 + close $f
1.5758 + set x
1.5759 +} {{script 1} {}}
1.5760 +
1.5761 +set path(bar) [makeFile {} bar]
1.5762 +
1.5763 +test io-48.1 {testing readability conditions} {fileevent} {
1.5764 + set f [open $path(bar) w]
1.5765 + puts $f abcdefg
1.5766 + puts $f abcdefg
1.5767 + puts $f abcdefg
1.5768 + puts $f abcdefg
1.5769 + puts $f abcdefg
1.5770 + close $f
1.5771 + set f [open $path(bar) r]
1.5772 + fileevent $f readable [namespace code [list consume $f]]
1.5773 + proc consume {f} {
1.5774 + variable l
1.5775 + variable x
1.5776 + lappend l called
1.5777 + if {[eof $f]} {
1.5778 + close $f
1.5779 + set x done
1.5780 + } else {
1.5781 + gets $f
1.5782 + }
1.5783 + }
1.5784 + set l ""
1.5785 + variable x not_done
1.5786 + vwait [namespace which -variable x]
1.5787 + list $x $l
1.5788 +} {done {called called called called called called called}}
1.5789 +test io-48.2 {testing readability conditions} {nonBlockFiles fileevent} {
1.5790 + set f [open $path(bar) w]
1.5791 + puts $f abcdefg
1.5792 + puts $f abcdefg
1.5793 + puts $f abcdefg
1.5794 + puts $f abcdefg
1.5795 + puts $f abcdefg
1.5796 + close $f
1.5797 + set f [open $path(bar) r]
1.5798 + fileevent $f readable [namespace code [list consume $f]]
1.5799 + fconfigure $f -blocking off
1.5800 + proc consume {f} {
1.5801 + variable x
1.5802 + variable l
1.5803 + lappend l called
1.5804 + if {[eof $f]} {
1.5805 + close $f
1.5806 + set x done
1.5807 + } else {
1.5808 + gets $f
1.5809 + }
1.5810 + }
1.5811 + set l ""
1.5812 + variable x not_done
1.5813 + vwait [namespace which -variable x]
1.5814 + list $x $l
1.5815 +} {done {called called called called called called called}}
1.5816 +
1.5817 +set path(my_script) [makeFile {} my_script]
1.5818 +
1.5819 +test io-48.3 {testing readability conditions} {stdio unixOnly nonBlockFiles openpipe fileevent} {
1.5820 + set f [open $path(bar) w]
1.5821 + puts $f abcdefg
1.5822 + puts $f abcdefg
1.5823 + puts $f abcdefg
1.5824 + puts $f abcdefg
1.5825 + puts $f abcdefg
1.5826 + close $f
1.5827 + set f [open $path(my_script) w]
1.5828 + puts $f {
1.5829 + proc copy_slowly {f} {
1.5830 + while {![eof $f]} {
1.5831 + puts [gets $f]
1.5832 + after 200
1.5833 + }
1.5834 + close $f
1.5835 + }
1.5836 + }
1.5837 + close $f
1.5838 + set f [open "|[list [interpreter]]" r+]
1.5839 + fileevent $f readable [namespace code [list consume $f]]
1.5840 + fconfigure $f -buffering line
1.5841 + fconfigure $f -blocking off
1.5842 + proc consume {f} {
1.5843 + variable l
1.5844 + variable x
1.5845 + if {[eof $f]} {
1.5846 + set x done
1.5847 + } else {
1.5848 + gets $f
1.5849 + lappend l [fblocked $f]
1.5850 + gets $f
1.5851 + lappend l [fblocked $f]
1.5852 + }
1.5853 + }
1.5854 + set l ""
1.5855 + variable x not_done
1.5856 + puts $f [list source $path(my_script)]
1.5857 + puts $f "set f \[[list open $path(bar) r]]"
1.5858 + puts $f {copy_slowly $f}
1.5859 + puts $f {exit}
1.5860 + vwait [namespace which -variable x]
1.5861 + close $f
1.5862 + list $x $l
1.5863 +} {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
1.5864 +test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fileevent} {
1.5865 + file delete $path(test1)
1.5866 + set f [open $path(test1) w]
1.5867 + fconfigure $f -translation lf
1.5868 + variable c [format "abc\ndef\n%c" 26]
1.5869 + puts -nonewline $f $c
1.5870 + close $f
1.5871 + proc consume {f} {
1.5872 + variable l
1.5873 + variable c
1.5874 + variable x
1.5875 + if {[eof $f]} {
1.5876 + set x done
1.5877 + close $f
1.5878 + } else {
1.5879 + lappend l [gets $f]
1.5880 + incr c
1.5881 + }
1.5882 + }
1.5883 + set c 0
1.5884 + set l ""
1.5885 + set f [open $path(test1) r]
1.5886 + fconfigure $f -translation auto -eofchar \x1a
1.5887 + fileevent $f readable [namespace code [list consume $f]]
1.5888 + variable x
1.5889 + vwait [namespace which -variable x]
1.5890 + list $c $l
1.5891 +} {3 {abc def {}}}
1.5892 +test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {fileevent} {
1.5893 + file delete $path(test1)
1.5894 + set f [open $path(test1) w]
1.5895 + fconfigure $f -translation lf
1.5896 + set c [format "abc\ndef\n%cfoo\nbar\n" 26]
1.5897 + puts -nonewline $f $c
1.5898 + close $f
1.5899 + proc consume {f} {
1.5900 + variable l
1.5901 + variable x
1.5902 + variable c
1.5903 + if {[eof $f]} {
1.5904 + set x done
1.5905 + close $f
1.5906 + } else {
1.5907 + lappend l [gets $f]
1.5908 + incr c
1.5909 + }
1.5910 + }
1.5911 + set c 0
1.5912 + set l ""
1.5913 + set f [open $path(test1) r]
1.5914 + fconfigure $f -eofchar \x1a -translation auto
1.5915 + fileevent $f readable [namespace code [list consume $f]]
1.5916 + variable x
1.5917 + vwait [namespace which -variable x]
1.5918 + list $c $l
1.5919 +} {3 {abc def {}}}
1.5920 +test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fileevent} {
1.5921 + file delete $path(test1)
1.5922 + set f [open $path(test1) w]
1.5923 + fconfigure $f -translation cr
1.5924 + set c [format "abc\ndef\n%c" 26]
1.5925 + puts -nonewline $f $c
1.5926 + close $f
1.5927 + proc consume {f} {
1.5928 + variable l
1.5929 + variable x
1.5930 + variable c
1.5931 + if {[eof $f]} {
1.5932 + set x done
1.5933 + close $f
1.5934 + } else {
1.5935 + lappend l [gets $f]
1.5936 + incr c
1.5937 + }
1.5938 + }
1.5939 + set c 0
1.5940 + set l ""
1.5941 + set f [open $path(test1) r]
1.5942 + fconfigure $f -translation auto -eofchar \x1a
1.5943 + fileevent $f readable [namespace code [list consume $f]]
1.5944 + variable x
1.5945 + vwait [namespace which -variable x]
1.5946 + list $c $l
1.5947 +} {3 {abc def {}}}
1.5948 +test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {fileevent} {
1.5949 + file delete $path(test1)
1.5950 + set f [open $path(test1) w]
1.5951 + fconfigure $f -translation cr
1.5952 + set c [format "abc\ndef\n%cfoo\nbar\n" 26]
1.5953 + puts -nonewline $f $c
1.5954 + close $f
1.5955 + proc consume {f} {
1.5956 + variable l
1.5957 + variable c
1.5958 + variable x
1.5959 + if {[eof $f]} {
1.5960 + set x done
1.5961 + close $f
1.5962 + } else {
1.5963 + lappend l [gets $f]
1.5964 + incr c
1.5965 + }
1.5966 + }
1.5967 + set c 0
1.5968 + set l ""
1.5969 + set f [open $path(test1) r]
1.5970 + fconfigure $f -eofchar \x1a -translation auto
1.5971 + fileevent $f readable [namespace code [list consume $f]]
1.5972 + variable x
1.5973 + vwait [namespace which -variable x]
1.5974 + list $c $l
1.5975 +} {3 {abc def {}}}
1.5976 +test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} {fileevent} {
1.5977 + file delete $path(test1)
1.5978 + set f [open $path(test1) w]
1.5979 + fconfigure $f -translation crlf
1.5980 + set c [format "abc\ndef\n%c" 26]
1.5981 + puts -nonewline $f $c
1.5982 + close $f
1.5983 + proc consume {f} {
1.5984 + variable l
1.5985 + variable x
1.5986 + variable c
1.5987 + if {[eof $f]} {
1.5988 + set x done
1.5989 + close $f
1.5990 + } else {
1.5991 + lappend l [gets $f]
1.5992 + incr c
1.5993 + }
1.5994 + }
1.5995 + set c 0
1.5996 + set l ""
1.5997 + set f [open $path(test1) r]
1.5998 + fconfigure $f -translation auto -eofchar \x1a
1.5999 + fileevent $f readable [namespace code [list consume $f]]
1.6000 + variable x
1.6001 + vwait [namespace which -variable x]
1.6002 + list $c $l
1.6003 +} {3 {abc def {}}}
1.6004 +test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fileevent} {
1.6005 + file delete $path(test1)
1.6006 + set f [open $path(test1) w]
1.6007 + fconfigure $f -translation crlf
1.6008 + set c [format "abc\ndef\n%cfoo\nbar\n" 26]
1.6009 + puts -nonewline $f $c
1.6010 + close $f
1.6011 + proc consume {f} {
1.6012 + variable l
1.6013 + variable c
1.6014 + variable x
1.6015 + if {[eof $f]} {
1.6016 + set x done
1.6017 + close $f
1.6018 + } else {
1.6019 + lappend l [gets $f]
1.6020 + incr c
1.6021 + }
1.6022 + }
1.6023 + set c 0
1.6024 + set l ""
1.6025 + set f [open $path(test1) r]
1.6026 + fconfigure $f -eofchar \x1a -translation auto
1.6027 + fileevent $f readable [namespace code [list consume $f]]
1.6028 + variable x
1.6029 + vwait [namespace which -variable x]
1.6030 + list $c $l
1.6031 +} {3 {abc def {}}}
1.6032 +test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {fileevent} {
1.6033 + file delete $path(test1)
1.6034 + set f [open $path(test1) w]
1.6035 + fconfigure $f -translation lf
1.6036 + set c [format "abc\ndef\n%cfoo\nbar\n" 26]
1.6037 + puts -nonewline $f $c
1.6038 + close $f
1.6039 + proc consume {f} {
1.6040 + variable l
1.6041 + variable c
1.6042 + variable x
1.6043 + if {[eof $f]} {
1.6044 + set x done
1.6045 + close $f
1.6046 + } else {
1.6047 + lappend l [gets $f]
1.6048 + incr c
1.6049 + }
1.6050 + }
1.6051 + set c 0
1.6052 + set l ""
1.6053 + set f [open $path(test1) r]
1.6054 + fconfigure $f -eofchar \x1a -translation lf
1.6055 + fileevent $f readable [namespace code [list consume $f]]
1.6056 + variable x
1.6057 + vwait [namespace which -variable x]
1.6058 + list $c $l
1.6059 +} {3 {abc def {}}}
1.6060 +test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fileevent} {
1.6061 + file delete $path(test1)
1.6062 + set f [open $path(test1) w]
1.6063 + fconfigure $f -translation lf
1.6064 + set c [format "abc\ndef\n%c" 26]
1.6065 + puts -nonewline $f $c
1.6066 + close $f
1.6067 + proc consume {f} {
1.6068 + variable l
1.6069 + variable x
1.6070 + variable c
1.6071 + if {[eof $f]} {
1.6072 + set x done
1.6073 + close $f
1.6074 + } else {
1.6075 + lappend l [gets $f]
1.6076 + incr c
1.6077 + }
1.6078 + }
1.6079 + set c 0
1.6080 + set l ""
1.6081 + set f [open $path(test1) r]
1.6082 + fconfigure $f -translation lf -eofchar \x1a
1.6083 + fileevent $f readable [namespace code [list consume $f]]
1.6084 + variable x
1.6085 + vwait [namespace which -variable x]
1.6086 + list $c $l
1.6087 +} {3 {abc def {}}}
1.6088 +test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {fileevent} {
1.6089 + file delete $path(test1)
1.6090 + set f [open $path(test1) w]
1.6091 + fconfigure $f -translation cr
1.6092 + set c [format "abc\ndef\n%cfoo\nbar\n" 26]
1.6093 + puts -nonewline $f $c
1.6094 + close $f
1.6095 + proc consume {f} {
1.6096 + variable l
1.6097 + variable x
1.6098 + variable c
1.6099 + if {[eof $f]} {
1.6100 + set x done
1.6101 + close $f
1.6102 + } else {
1.6103 + lappend l [gets $f]
1.6104 + incr c
1.6105 + }
1.6106 + }
1.6107 + set c 0
1.6108 + set l ""
1.6109 + set f [open $path(test1) r]
1.6110 + fconfigure $f -eofchar \x1a -translation cr
1.6111 + fileevent $f readable [namespace code [list consume $f]]
1.6112 + variable x
1.6113 + vwait [namespace which -variable x]
1.6114 + list $c $l
1.6115 +} {3 {abc def {}}}
1.6116 +test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fileevent} {
1.6117 + file delete $path(test1)
1.6118 + set f [open $path(test1) w]
1.6119 + fconfigure $f -translation cr
1.6120 + set c [format "abc\ndef\n%c" 26]
1.6121 + puts -nonewline $f $c
1.6122 + close $f
1.6123 + proc consume {f} {
1.6124 + variable c
1.6125 + variable x
1.6126 + variable l
1.6127 + if {[eof $f]} {
1.6128 + set x done
1.6129 + close $f
1.6130 + } else {
1.6131 + lappend l [gets $f]
1.6132 + incr c
1.6133 + }
1.6134 + }
1.6135 + set c 0
1.6136 + set l ""
1.6137 + set f [open $path(test1) r]
1.6138 + fconfigure $f -translation cr -eofchar \x1a
1.6139 + fileevent $f readable [namespace code [list consume $f]]
1.6140 + variable x
1.6141 + vwait [namespace which -variable x]
1.6142 + list $c $l
1.6143 +} {3 {abc def {}}}
1.6144 +test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {fileevent} {
1.6145 + file delete $path(test1)
1.6146 + set f [open $path(test1) w]
1.6147 + fconfigure $f -translation crlf
1.6148 + set c [format "abc\ndef\n%cfoo\nbar\n" 26]
1.6149 + puts -nonewline $f $c
1.6150 + close $f
1.6151 + proc consume {f} {
1.6152 + variable c
1.6153 + variable x
1.6154 + variable l
1.6155 + if {[eof $f]} {
1.6156 + set x done
1.6157 + close $f
1.6158 + } else {
1.6159 + lappend l [gets $f]
1.6160 + incr c
1.6161 + }
1.6162 + }
1.6163 + set c 0
1.6164 + set l ""
1.6165 + set f [open $path(test1) r]
1.6166 + fconfigure $f -eofchar \x1a -translation crlf
1.6167 + fileevent $f readable [namespace code [list consume $f]]
1.6168 + variable x
1.6169 + vwait [namespace which -variable x]
1.6170 + list $c $l
1.6171 +} {3 {abc def {}}}
1.6172 +test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {fileevent} {
1.6173 + file delete $path(test1)
1.6174 + set f [open $path(test1) w]
1.6175 + fconfigure $f -translation crlf
1.6176 + set c [format "abc\ndef\n%c" 26]
1.6177 + puts -nonewline $f $c
1.6178 + close $f
1.6179 + proc consume {f} {
1.6180 + variable c
1.6181 + variable x
1.6182 + variable l
1.6183 + if {[eof $f]} {
1.6184 + set x done
1.6185 + close $f
1.6186 + } else {
1.6187 + lappend l [gets $f]
1.6188 + incr c
1.6189 + }
1.6190 + }
1.6191 + set c 0
1.6192 + set l ""
1.6193 + set f [open $path(test1) r]
1.6194 + fconfigure $f -translation crlf -eofchar \x1a
1.6195 + fileevent $f readable [namespace code [list consume $f]]
1.6196 + variable x
1.6197 + vwait [namespace which -variable x]
1.6198 + list $c $l
1.6199 +} {3 {abc def {}}}
1.6200 +
1.6201 +test io-49.1 {testing crlf reading, leftover cr disgorgment} {
1.6202 + file delete $path(test1)
1.6203 + set f [open $path(test1) w]
1.6204 + fconfigure $f -translation lf
1.6205 + puts -nonewline $f "a\rb\rc\r\n"
1.6206 + close $f
1.6207 + set f [open $path(test1) r]
1.6208 + set l ""
1.6209 + lappend l [file size $path(test1)]
1.6210 + fconfigure $f -translation crlf
1.6211 + lappend l [read $f 1]
1.6212 + lappend l [tell $f]
1.6213 + lappend l [read $f 1]
1.6214 + lappend l [tell $f]
1.6215 + lappend l [read $f 1]
1.6216 + lappend l [tell $f]
1.6217 + lappend l [read $f 1]
1.6218 + lappend l [tell $f]
1.6219 + lappend l [read $f 1]
1.6220 + lappend l [tell $f]
1.6221 + lappend l [read $f 1]
1.6222 + lappend l [tell $f]
1.6223 + lappend l [eof $f]
1.6224 + lappend l [read $f 1]
1.6225 + lappend l [eof $f]
1.6226 + close $f
1.6227 + set l
1.6228 +} "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 {
1.6229 +} 7 0 {} 1"
1.6230 +test io-49.2 {testing crlf reading, leftover cr disgorgment} {
1.6231 + file delete $path(test1)
1.6232 + set f [open $path(test1) w]
1.6233 + fconfigure $f -translation lf
1.6234 + puts -nonewline $f "a\rb\rc\r\n"
1.6235 + close $f
1.6236 + set f [open $path(test1) r]
1.6237 + set l ""
1.6238 + lappend l [file size $path(test1)]
1.6239 + fconfigure $f -translation crlf
1.6240 + lappend l [read $f 2]
1.6241 + lappend l [tell $f]
1.6242 + lappend l [read $f 2]
1.6243 + lappend l [tell $f]
1.6244 + lappend l [read $f 2]
1.6245 + lappend l [tell $f]
1.6246 + lappend l [eof $f]
1.6247 + lappend l [read $f 2]
1.6248 + lappend l [tell $f]
1.6249 + lappend l [eof $f]
1.6250 + close $f
1.6251 + set l
1.6252 +} "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1"
1.6253 +test io-49.3 {testing crlf reading, leftover cr disgorgment} {
1.6254 + file delete $path(test1)
1.6255 + set f [open $path(test1) w]
1.6256 + fconfigure $f -translation lf
1.6257 + puts -nonewline $f "a\rb\rc\r\n"
1.6258 + close $f
1.6259 + set f [open $path(test1) r]
1.6260 + set l ""
1.6261 + lappend l [file size $path(test1)]
1.6262 + fconfigure $f -translation crlf
1.6263 + lappend l [read $f 3]
1.6264 + lappend l [tell $f]
1.6265 + lappend l [read $f 3]
1.6266 + lappend l [tell $f]
1.6267 + lappend l [eof $f]
1.6268 + lappend l [read $f 3]
1.6269 + lappend l [tell $f]
1.6270 + lappend l [eof $f]
1.6271 + close $f
1.6272 + set l
1.6273 +} "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1"
1.6274 +test io-49.4 {testing crlf reading, leftover cr disgorgment} {
1.6275 + file delete $path(test1)
1.6276 + set f [open $path(test1) w]
1.6277 + fconfigure $f -translation lf
1.6278 + puts -nonewline $f "a\rb\rc\r\n"
1.6279 + close $f
1.6280 + set f [open $path(test1) r]
1.6281 + set l ""
1.6282 + lappend l [file size $path(test1)]
1.6283 + fconfigure $f -translation crlf
1.6284 + lappend l [read $f 3]
1.6285 + lappend l [tell $f]
1.6286 + lappend l [gets $f]
1.6287 + lappend l [tell $f]
1.6288 + lappend l [eof $f]
1.6289 + lappend l [gets $f]
1.6290 + lappend l [tell $f]
1.6291 + lappend l [eof $f]
1.6292 + close $f
1.6293 + set l
1.6294 +} "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1"
1.6295 +test io-49.5 {testing crlf reading, leftover cr disgorgment} {
1.6296 + file delete $path(test1)
1.6297 + set f [open $path(test1) w]
1.6298 + fconfigure $f -translation lf
1.6299 + puts -nonewline $f "a\rb\rc\r\n"
1.6300 + close $f
1.6301 + set f [open $path(test1) r]
1.6302 + set l ""
1.6303 + lappend l [file size $path(test1)]
1.6304 + fconfigure $f -translation crlf
1.6305 + lappend l [set x [gets $f]]
1.6306 + lappend l [tell $f]
1.6307 + lappend l [gets $f]
1.6308 + lappend l [tell $f]
1.6309 + lappend l [eof $f]
1.6310 + close $f
1.6311 + set l
1.6312 +} [list 7 a\rb\rc 7 {} 7 1]
1.6313 +
1.6314 +testConstraint testchannelevent [llength [info commands testchannelevent]]
1.6315 +test io-50.1 {testing handler deletion} {testchannelevent} {
1.6316 + file delete $path(test1)
1.6317 + set f [open $path(test1) w]
1.6318 + close $f
1.6319 + set f [open $path(test1) r]
1.6320 + testchannelevent $f add readable [namespace code [list delhandler $f]]
1.6321 + proc delhandler {f} {
1.6322 + variable z
1.6323 + set z called
1.6324 + testchannelevent $f delete 0
1.6325 + }
1.6326 + set z not_called
1.6327 + update
1.6328 + close $f
1.6329 + set z
1.6330 +} called
1.6331 +test io-50.2 {testing handler deletion with multiple handlers} {testchannelevent} {
1.6332 + file delete $path(test1)
1.6333 + set f [open $path(test1) w]
1.6334 + close $f
1.6335 + set f [open $path(test1) r]
1.6336 + testchannelevent $f add readable [namespace code [list delhandler $f 1]]
1.6337 + testchannelevent $f add readable [namespace code [list delhandler $f 0]]
1.6338 + proc delhandler {f i} {
1.6339 + variable z
1.6340 + lappend z "called delhandler $f $i"
1.6341 + testchannelevent $f delete 0
1.6342 + }
1.6343 + set z ""
1.6344 + update
1.6345 + close $f
1.6346 + string compare [string tolower $z] \
1.6347 + [list [list called delhandler $f 0] [list called delhandler $f 1]]
1.6348 +} 0
1.6349 +test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent} {
1.6350 + file delete $path(test1)
1.6351 + set f [open $path(test1) w]
1.6352 + close $f
1.6353 + set f [open $path(test1) r]
1.6354 + testchannelevent $f add readable [namespace code [list notcalled $f 1]]
1.6355 + testchannelevent $f add readable [namespace code [list delhandler $f 0]]
1.6356 + set z ""
1.6357 + proc notcalled {f i} {
1.6358 + variable z
1.6359 + lappend z "notcalled was called!! $f $i"
1.6360 + }
1.6361 + proc delhandler {f i} {
1.6362 + variable z
1.6363 + testchannelevent $f delete 1
1.6364 + lappend z "delhandler $f $i called"
1.6365 + testchannelevent $f delete 0
1.6366 + lappend z "delhandler $f $i deleted myself"
1.6367 + }
1.6368 + set z ""
1.6369 + update
1.6370 + close $f
1.6371 + string compare [string tolower $z] \
1.6372 + [list [list delhandler $f 0 called] \
1.6373 + [list delhandler $f 0 deleted myself]]
1.6374 +} 0
1.6375 +test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} {
1.6376 + file delete $path(test1)
1.6377 + set f [open $path(test1) w]
1.6378 + close $f
1.6379 + set f [open $path(test1) r]
1.6380 + testchannelevent $f add readable [namespace code [list delrecursive $f]]
1.6381 + proc delrecursive {f} {
1.6382 + variable z
1.6383 + variable u
1.6384 + if {"$u" == "recursive"} {
1.6385 + testchannelevent $f delete 0
1.6386 + lappend z "delrecursive deleting recursive"
1.6387 + } else {
1.6388 + lappend z "delrecursive calling recursive"
1.6389 + set u recursive
1.6390 + update
1.6391 + }
1.6392 + }
1.6393 + set u toplevel
1.6394 + set z ""
1.6395 + update
1.6396 + close $f
1.6397 + string compare [string tolower $z] \
1.6398 + {{delrecursive calling recursive} {delrecursive deleting recursive}}
1.6399 +} 0
1.6400 +test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} {
1.6401 + file delete $path(test1)
1.6402 + set f [open $path(test1) w]
1.6403 + close $f
1.6404 + set f [open $path(test1) r]
1.6405 + testchannelevent $f add readable [namespace code [list notcalled $f]]
1.6406 + testchannelevent $f add readable [namespace code [list del $f]]
1.6407 + proc notcalled {f} {
1.6408 + variable z
1.6409 + lappend z "notcalled was called!! $f"
1.6410 + }
1.6411 + proc del {f} {
1.6412 + variable u
1.6413 + variable z
1.6414 + if {"$u" == "recursive"} {
1.6415 + testchannelevent $f delete 1
1.6416 + testchannelevent $f delete 0
1.6417 + lappend z "del deleted notcalled"
1.6418 + lappend z "del deleted myself"
1.6419 + } else {
1.6420 + set u recursive
1.6421 + lappend z "del calling recursive"
1.6422 + update
1.6423 + lappend z "del after update"
1.6424 + }
1.6425 + }
1.6426 + set z ""
1.6427 + set u toplevel
1.6428 + update
1.6429 + close $f
1.6430 + string compare [string tolower $z] \
1.6431 + [list {del calling recursive} {del deleted notcalled} \
1.6432 + {del deleted myself} {del after update}]
1.6433 +} 0
1.6434 +test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} {
1.6435 + file delete $path(test1)
1.6436 + set f [open $path(test1) w]
1.6437 + close $f
1.6438 + set f [open $path(test1) r]
1.6439 + testchannelevent $f add readable [namespace code [list second $f]]
1.6440 + testchannelevent $f add readable [namespace code [list first $f]]
1.6441 + proc first {f} {
1.6442 + variable u
1.6443 + variable z
1.6444 + if {"$u" == "toplevel"} {
1.6445 + lappend z "first called"
1.6446 + set u first
1.6447 + update
1.6448 + lappend z "first after update"
1.6449 + } else {
1.6450 + lappend z "first called not toplevel"
1.6451 + }
1.6452 + }
1.6453 + proc second {f} {
1.6454 + variable u
1.6455 + variable z
1.6456 + if {"$u" == "first"} {
1.6457 + lappend z "second called, first time"
1.6458 + set u second
1.6459 + testchannelevent $f delete 0
1.6460 + } elseif {"$u" == "second"} {
1.6461 + lappend z "second called, second time"
1.6462 + testchannelevent $f delete 0
1.6463 + } else {
1.6464 + lappend z "second called, cannot happen!"
1.6465 + testchannelevent $f removeall
1.6466 + }
1.6467 + }
1.6468 + set z ""
1.6469 + set u toplevel
1.6470 + update
1.6471 + close $f
1.6472 + string compare [string tolower $z] \
1.6473 + [list {first called} {first called not toplevel} \
1.6474 + {second called, first time} {second called, second time} \
1.6475 + {first after update}]
1.6476 +} 0
1.6477 +
1.6478 +test io-51.1 {Test old socket deletion on Macintosh} {socket} {
1.6479 + set x 0
1.6480 + set result ""
1.6481 + proc accept {s a p} {
1.6482 + variable x
1.6483 + variable wait
1.6484 + fconfigure $s -blocking off
1.6485 + puts $s "sock[incr x]"
1.6486 + close $s
1.6487 + set wait done
1.6488 + }
1.6489 + set ss [socket -server [namespace code accept] 0]
1.6490 + variable wait ""
1.6491 + set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
1.6492 + vwait [namespace which -variable wait]
1.6493 + lappend result [gets $cs]
1.6494 + close $cs
1.6495 +
1.6496 + set wait ""
1.6497 + set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
1.6498 + vwait [namespace which -variable wait]
1.6499 + lappend result [gets $cs]
1.6500 + close $cs
1.6501 +
1.6502 + set wait ""
1.6503 + set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
1.6504 + vwait [namespace which -variable wait]
1.6505 + lappend result [gets $cs]
1.6506 + close $cs
1.6507 +
1.6508 + set wait ""
1.6509 + set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
1.6510 + vwait [namespace which -variable wait]
1.6511 + lappend result [gets $cs]
1.6512 + close $cs
1.6513 + close $ss
1.6514 + set result
1.6515 +} {sock1 sock2 sock3 sock4}
1.6516 +
1.6517 +test io-52.1 {TclCopyChannel} {fcopy} {
1.6518 + file delete $path(test1)
1.6519 + set f1 [open $thisScript]
1.6520 + set f2 [open $path(test1) w]
1.6521 + fcopy $f1 $f2 -command { # }
1.6522 + catch { fcopy $f1 $f2 } msg
1.6523 + close $f1
1.6524 + close $f2
1.6525 + string compare $msg "channel \"$f1\" is busy"
1.6526 +} {0}
1.6527 +test io-52.2 {TclCopyChannel} {fcopy} {
1.6528 + file delete $path(test1)
1.6529 + set f1 [open $thisScript]
1.6530 + set f2 [open $path(test1) w]
1.6531 + set f3 [open $thisScript]
1.6532 + fcopy $f1 $f2 -command { # }
1.6533 + catch { fcopy $f3 $f2 } msg
1.6534 + close $f1
1.6535 + close $f2
1.6536 + close $f3
1.6537 + string compare $msg "channel \"$f2\" is busy"
1.6538 +} {0}
1.6539 +test io-52.3 {TclCopyChannel} {fcopy} {
1.6540 + file delete $path(test1)
1.6541 + set f1 [open $thisScript]
1.6542 + set f2 [open $path(test1) w]
1.6543 + fconfigure $f1 -translation lf -blocking 0
1.6544 + fconfigure $f2 -translation cr -blocking 0
1.6545 + set s0 [fcopy $f1 $f2]
1.6546 + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
1.6547 + close $f1
1.6548 + close $f2
1.6549 + set s1 [file size $thisScript]
1.6550 + set s2 [file size $path(test1)]
1.6551 + if {("$s1" == "$s2") && ($s0 == $s1)} {
1.6552 + lappend result ok
1.6553 + }
1.6554 + set result
1.6555 +} {0 0 ok}
1.6556 +test io-52.4 {TclCopyChannel} {fcopy} {
1.6557 + file delete $path(test1)
1.6558 + set f1 [open $thisScript]
1.6559 + set f2 [open $path(test1) w]
1.6560 + fconfigure $f1 -translation lf -blocking 0
1.6561 + fconfigure $f2 -translation cr -blocking 0
1.6562 + fcopy $f1 $f2 -size 40
1.6563 + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
1.6564 + close $f1
1.6565 + close $f2
1.6566 + lappend result [file size $path(test1)]
1.6567 +} {0 0 40}
1.6568 +test io-52.5 {TclCopyChannel} {fcopy} {
1.6569 + file delete $path(test1)
1.6570 + set f1 [open $thisScript]
1.6571 + set f2 [open $path(test1) w]
1.6572 + fconfigure $f1 -translation lf -blocking 0
1.6573 + fconfigure $f2 -translation lf -blocking 0
1.6574 + fcopy $f1 $f2 -size -1
1.6575 + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
1.6576 + close $f1
1.6577 + close $f2
1.6578 + set s1 [file size $thisScript]
1.6579 + set s2 [file size $path(test1)]
1.6580 + if {"$s1" == "$s2"} {
1.6581 + lappend result ok
1.6582 + }
1.6583 + set result
1.6584 +} {0 0 ok}
1.6585 +test io-52.6 {TclCopyChannel} {fcopy} {
1.6586 + file delete $path(test1)
1.6587 + set f1 [open $thisScript]
1.6588 + set f2 [open $path(test1) w]
1.6589 + fconfigure $f1 -translation lf -blocking 0
1.6590 + fconfigure $f2 -translation lf -blocking 0
1.6591 + set s0 [fcopy $f1 $f2 -size [expr [file size $thisScript] + 5]]
1.6592 + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
1.6593 + close $f1
1.6594 + close $f2
1.6595 + set s1 [file size $thisScript]
1.6596 + set s2 [file size $path(test1)]
1.6597 + if {("$s1" == "$s2") && ($s0 == $s1)} {
1.6598 + lappend result ok
1.6599 + }
1.6600 + set result
1.6601 +} {0 0 ok}
1.6602 +test io-52.7 {TclCopyChannel} {fcopy} {
1.6603 + file delete $path(test1)
1.6604 + set f1 [open $thisScript]
1.6605 + set f2 [open $path(test1) w]
1.6606 + fconfigure $f1 -translation lf -blocking 0
1.6607 + fconfigure $f2 -translation lf -blocking 0
1.6608 + fcopy $f1 $f2
1.6609 + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
1.6610 + set s1 [file size $thisScript]
1.6611 + set s2 [file size $path(test1)]
1.6612 + close $f1
1.6613 + close $f2
1.6614 + if {"$s1" == "$s2"} {
1.6615 + lappend result ok
1.6616 + }
1.6617 + set result
1.6618 +} {0 0 ok}
1.6619 +test io-52.8 {TclCopyChannel} {stdio openpipe fcopy} {
1.6620 + file delete $path(test1)
1.6621 + file delete $path(pipe)
1.6622 + set f1 [open $path(pipe) w]
1.6623 + fconfigure $f1 -translation lf
1.6624 + puts $f1 "
1.6625 + puts ready
1.6626 + gets stdin
1.6627 + set f1 \[open [list $thisScript] r\]
1.6628 + fconfigure \$f1 -translation lf
1.6629 + puts \[read \$f1 100\]
1.6630 + close \$f1
1.6631 + "
1.6632 + close $f1
1.6633 + set f1 [open "|[list [interpreter] $path(pipe)]" r+]
1.6634 + fconfigure $f1 -translation lf
1.6635 + gets $f1
1.6636 + puts $f1 ready
1.6637 + flush $f1
1.6638 + set f2 [open $path(test1) w]
1.6639 + fconfigure $f2 -translation lf
1.6640 + set s0 [fcopy $f1 $f2 -size 40]
1.6641 + catch {close $f1}
1.6642 + close $f2
1.6643 + list $s0 [file size $path(test1)]
1.6644 +} {40 40}
1.6645 +
1.6646 +# Empty files, to register them with the test facility
1.6647 +set path(kyrillic.txt) [makeFile {} kyrillic.txt]
1.6648 +set path(utf8-fcopy.txt) [makeFile {} utf8-fcopy.txt]
1.6649 +set path(utf8-rp.txt) [makeFile {} utf8-rp.txt]
1.6650 +
1.6651 +# Create kyrillic file, use lf translation to avoid os eol issues
1.6652 +set out [open $path(kyrillic.txt) w]
1.6653 +fconfigure $out -encoding koi8-r -translation lf
1.6654 +puts $out "\u0410\u0410"
1.6655 +close $out
1.6656 +
1.6657 +test io-52.9 {TclCopyChannel & encodings} {fcopy} {
1.6658 + # Copy kyrillic to UTF-8, using fcopy.
1.6659 +
1.6660 + set in [open $path(kyrillic.txt) r]
1.6661 + set out [open $path(utf8-fcopy.txt) w]
1.6662 +
1.6663 + fconfigure $in -encoding koi8-r -translation lf
1.6664 + fconfigure $out -encoding utf-8 -translation lf
1.6665 +
1.6666 + fcopy $in $out
1.6667 + close $in
1.6668 + close $out
1.6669 +
1.6670 + # Do the same again, but differently (read/puts).
1.6671 +
1.6672 + set in [open $path(kyrillic.txt) r]
1.6673 + set out [open $path(utf8-rp.txt) w]
1.6674 +
1.6675 + fconfigure $in -encoding koi8-r -translation lf
1.6676 + fconfigure $out -encoding utf-8 -translation lf
1.6677 +
1.6678 + puts -nonewline $out [read $in]
1.6679 +
1.6680 + close $in
1.6681 + close $out
1.6682 +
1.6683 + list [file size $path(kyrillic.txt)] \
1.6684 + [file size $path(utf8-fcopy.txt)] \
1.6685 + [file size $path(utf8-rp.txt)]
1.6686 +} {3 5 5}
1.6687 +
1.6688 +test io-52.10 {TclCopyChannel & encodings} {fcopy} {
1.6689 + # encoding to binary (=> implies that the
1.6690 + # internal utf-8 is written)
1.6691 +
1.6692 + set in [open $path(kyrillic.txt) r]
1.6693 + set out [open $path(utf8-fcopy.txt) w]
1.6694 +
1.6695 + fconfigure $in -encoding koi8-r -translation lf
1.6696 + # -translation binary is also -encoding binary
1.6697 + fconfigure $out -translation binary
1.6698 +
1.6699 + fcopy $in $out
1.6700 + close $in
1.6701 + close $out
1.6702 +
1.6703 + file size $path(utf8-fcopy.txt)
1.6704 +} 5
1.6705 +
1.6706 +test io-52.11 {TclCopyChannel & encodings} {fcopy} {
1.6707 + # binary to encoding => the input has to be
1.6708 + # in utf-8 to make sense to the encoder
1.6709 +
1.6710 + set in [open $path(utf8-fcopy.txt) r]
1.6711 + set out [open $path(kyrillic.txt) w]
1.6712 +
1.6713 + # -translation binary is also -encoding binary
1.6714 + fconfigure $in -translation binary
1.6715 + fconfigure $out -encoding koi8-r -translation lf
1.6716 +
1.6717 + fcopy $in $out
1.6718 + close $in
1.6719 + close $out
1.6720 +
1.6721 + file size $path(kyrillic.txt)
1.6722 +} 3
1.6723 +
1.6724 +test io-53.1 {CopyData} {fcopy} {
1.6725 + file delete $path(test1)
1.6726 + set f1 [open $thisScript]
1.6727 + set f2 [open $path(test1) w]
1.6728 + fconfigure $f1 -translation lf -blocking 0
1.6729 + fconfigure $f2 -translation cr -blocking 0
1.6730 + fcopy $f1 $f2 -size 0
1.6731 + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
1.6732 + close $f1
1.6733 + close $f2
1.6734 + lappend result [file size $path(test1)]
1.6735 +} {0 0 0}
1.6736 +test io-53.2 {CopyData} {fcopy} {
1.6737 + file delete $path(test1)
1.6738 + set f1 [open $thisScript]
1.6739 + set f2 [open $path(test1) w]
1.6740 + fconfigure $f1 -translation lf -blocking 0
1.6741 + fconfigure $f2 -translation cr -blocking 0
1.6742 + fcopy $f1 $f2 -command [namespace code {set s0}]
1.6743 + set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
1.6744 + variable s0
1.6745 + vwait [namespace which -variable s0]
1.6746 + close $f1
1.6747 + close $f2
1.6748 + set s1 [file size $thisScript]
1.6749 + set s2 [file size $path(test1)]
1.6750 + if {("$s1" == "$s2") && ($s0 == $s1)} {
1.6751 + lappend result ok
1.6752 + }
1.6753 + set result
1.6754 +} {0 0 ok}
1.6755 +test io-53.3 {CopyData: background read underflow} {stdio unixOnly openpipe fcopy} {
1.6756 + file delete $path(test1)
1.6757 + file delete $path(pipe)
1.6758 + set f1 [open $path(pipe) w]
1.6759 + puts -nonewline $f1 {
1.6760 + puts ready
1.6761 + flush stdout ;# Don't assume line buffered!
1.6762 + fcopy stdin stdout -command { set x }
1.6763 + vwait x
1.6764 + set f [}
1.6765 + puts $f1 [list open $path(test1) w]]
1.6766 + puts $f1 {
1.6767 + fconfigure $f -translation lf
1.6768 + puts $f "done"
1.6769 + close $f
1.6770 + }
1.6771 + close $f1
1.6772 + set f1 [open "|[list [interpreter] $path(pipe)]" r+]
1.6773 + set result [gets $f1]
1.6774 + puts $f1 line1
1.6775 + flush $f1
1.6776 + lappend result [gets $f1]
1.6777 + puts $f1 line2
1.6778 + flush $f1
1.6779 + lappend result [gets $f1]
1.6780 + close $f1
1.6781 + after 500
1.6782 + set f [open $path(test1)]
1.6783 + lappend result [read $f]
1.6784 + close $f
1.6785 + set result
1.6786 +} "ready line1 line2 {done\n}"
1.6787 +test io-53.4 {CopyData: background write overflow} {stdio unixOnly openpipe fileevent fcopy} {
1.6788 + set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
1.6789 + variable x
1.6790 + for {set x 0} {$x < 12} {incr x} {
1.6791 + append big $big
1.6792 + }
1.6793 + file delete $path(test1)
1.6794 + file delete $path(pipe)
1.6795 + set f1 [open $path(pipe) w]
1.6796 + puts $f1 {
1.6797 + puts ready
1.6798 + fcopy stdin stdout -command { set x }
1.6799 + vwait x
1.6800 + set f [open $path(test1) w]
1.6801 + fconfigure $f -translation lf
1.6802 + puts $f "done"
1.6803 + close $f
1.6804 + }
1.6805 + close $f1
1.6806 + set f1 [open "|[list [interpreter] $path(pipe)]" r+]
1.6807 + set result [gets $f1]
1.6808 + fconfigure $f1 -blocking 0
1.6809 + puts $f1 $big
1.6810 + flush $f1
1.6811 + after 500
1.6812 + set result ""
1.6813 + fileevent $f1 read [namespace code {
1.6814 + append result [read $f1 1024]
1.6815 + if {[string length $result] >= [string length $big]} {
1.6816 + set x done
1.6817 + }
1.6818 + }]
1.6819 + vwait [namespace which -variable x]
1.6820 + close $f1
1.6821 + set big {}
1.6822 + set x
1.6823 +} done
1.6824 +set result {}
1.6825 +
1.6826 +proc FcopyTestAccept {sock args} {
1.6827 + after 1000 "close $sock"
1.6828 +}
1.6829 +proc FcopyTestDone {bytes {error {}}} {
1.6830 + variable fcopyTestDone
1.6831 + if {[string length $error]} {
1.6832 + set fcopyTestDone 1
1.6833 + } else {
1.6834 + set fcopyTestDone 0
1.6835 + }
1.6836 +}
1.6837 +
1.6838 +test io-53.5 {CopyData: error during fcopy} {socket fcopy} {
1.6839 + variable fcopyTestDone
1.6840 + set listen [socket -server [namespace code FcopyTestAccept] 0]
1.6841 + set in [open $thisScript] ;# 126 K
1.6842 + set out [socket 127.0.0.1 [lindex [fconfigure $listen -sockname] 2]]
1.6843 + catch {unset fcopyTestDone}
1.6844 + close $listen ;# This means the socket open never really succeeds
1.6845 + fcopy $in $out -command [namespace code FcopyTestDone]
1.6846 + variable fcopyTestDone
1.6847 + if ![info exists fcopyTestDone] {
1.6848 + vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g.
1.6849 + }
1.6850 + close $in
1.6851 + close $out
1.6852 + set fcopyTestDone ;# 1 for error condition
1.6853 +} 1
1.6854 +test io-53.6 {CopyData: error during fcopy} {stdio openpipe fcopy} {
1.6855 + variable fcopyTestDone
1.6856 + file delete $path(pipe)
1.6857 + file delete $path(test1)
1.6858 + catch {unset fcopyTestDone}
1.6859 + set f1 [open $path(pipe) w]
1.6860 + puts $f1 "exit 1"
1.6861 + close $f1
1.6862 + set in [open "|[list [interpreter] $path(pipe)]" r+]
1.6863 + set out [open $path(test1) w]
1.6864 + fcopy $in $out -command [namespace code FcopyTestDone]
1.6865 + variable fcopyTestDone
1.6866 + if ![info exists fcopyTestDone] {
1.6867 + vwait [namespace which -variable fcopyTestDone]
1.6868 + }
1.6869 + catch {close $in}
1.6870 + close $out
1.6871 + set fcopyTestDone ;# 0 for plain end of file
1.6872 +} {0}
1.6873 +
1.6874 +proc doFcopy {in out {bytes 0} {error {}}} {
1.6875 + variable fcopyTestDone
1.6876 + variable fcopyTestCount
1.6877 + incr fcopyTestCount $bytes
1.6878 + if {[string length $error]} {
1.6879 + set fcopyTestDone 1
1.6880 + } elseif {[eof $in]} {
1.6881 + set fcopyTestDone 0
1.6882 + } else {
1.6883 + # Delay next fcopy to wait for size>0 input bytes
1.6884 + after 100 [list
1.6885 + fcopy $in $out -size 1000 \
1.6886 + -command [namespace code [list doFcopy $in $out]]
1.6887 + ]
1.6888 + }
1.6889 +}
1.6890 +
1.6891 +test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio openpipe fcopy} {
1.6892 + variable fcopyTestDone
1.6893 + file delete $path(pipe)
1.6894 + catch {unset fcopyTestDone}
1.6895 + set fcopyTestCount 0
1.6896 + set f1 [open $path(pipe) w]
1.6897 + puts $f1 {
1.6898 + # Write 10 bytes / 10 msec
1.6899 + proc Write {count} {
1.6900 + puts -nonewline "1234567890"
1.6901 + if {[incr count -1]} {
1.6902 + after 10 [list Write $count]
1.6903 + } else {
1.6904 + set ::ready 1
1.6905 + }
1.6906 + }
1.6907 + fconfigure stdout -buffering none
1.6908 + Write 345 ;# 3450 bytes ~3.45 sec
1.6909 + vwait ready
1.6910 + exit 0
1.6911 + }
1.6912 + close $f1
1.6913 + set in [open "|[list [interpreter] $path(pipe) &]" r+]
1.6914 + set out [open $path(test1) w]
1.6915 + doFcopy $in $out
1.6916 + variable fcopyTestDone
1.6917 + if ![info exists fcopyTestDone] {
1.6918 + vwait [namespace which -variable fcopyTestDone]
1.6919 + }
1.6920 + catch {close $in}
1.6921 + close $out
1.6922 + # -1=error 0=script error N=number of bytes
1.6923 + expr ($fcopyTestDone == 0) ? $fcopyTestCount : -1
1.6924 +} {3450}
1.6925 +
1.6926 +test io-54.1 {Recursive channel events} {socket fileevent} {
1.6927 + # This test checks to see if file events are delivered during recursive
1.6928 + # event loops when there is buffered data on the channel.
1.6929 +
1.6930 + proc accept {s a p} {
1.6931 + variable as
1.6932 + fconfigure $s -translation lf
1.6933 + puts $s "line 1\nline2\nline3"
1.6934 + flush $s
1.6935 + set as $s
1.6936 + }
1.6937 + proc readit {s next} {
1.6938 + variable x
1.6939 + variable result
1.6940 + lappend result $next
1.6941 + if {$next == 1} {
1.6942 + fileevent $s readable [namespace code [list readit $s 2]]
1.6943 + vwait [namespace which -variable x]
1.6944 + }
1.6945 + incr x
1.6946 + }
1.6947 + set ss [socket -server [namespace code accept] 0]
1.6948 +
1.6949 + # We need to delay on some systems until the creation of the
1.6950 + # server socket completes.
1.6951 +
1.6952 + set done 0
1.6953 + for {set i 0} {$i < 10} {incr i} {
1.6954 + if {![catch {set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]}]} {
1.6955 + set done 1
1.6956 + break
1.6957 + }
1.6958 + after 100
1.6959 + }
1.6960 + if {$done == 0} {
1.6961 + close $ss
1.6962 + error "failed to connect to server"
1.6963 + }
1.6964 + variable result {}
1.6965 + variable x 0
1.6966 + variable as
1.6967 + vwait [namespace which -variable as]
1.6968 + fconfigure $cs -translation lf
1.6969 + lappend result [gets $cs]
1.6970 + fconfigure $cs -blocking off
1.6971 + fileevent $cs readable [namespace code [list readit $cs 1]]
1.6972 + set a [after 2000 [namespace code { set x failure }]]
1.6973 + vwait [namespace which -variable x]
1.6974 + after cancel $a
1.6975 + close $as
1.6976 + close $ss
1.6977 + close $cs
1.6978 + list $result $x
1.6979 +} {{{line 1} 1 2} 2}
1.6980 +test io-54.2 {Testing for busy-wait in recursive channel events} {socket fileevent} {
1.6981 + set accept {}
1.6982 + set after {}
1.6983 + variable s [socket -server [namespace code accept] 0]
1.6984 + proc accept {s a p} {
1.6985 + variable counter
1.6986 + variable accept
1.6987 +
1.6988 + set accept $s
1.6989 + set counter 0
1.6990 + fconfigure $s -blocking off -buffering line -translation lf
1.6991 + fileevent $s readable [namespace code "doit $s"]
1.6992 + }
1.6993 + proc doit {s} {
1.6994 + variable counter
1.6995 + variable after
1.6996 +
1.6997 + incr counter
1.6998 + set l [gets $s]
1.6999 + if {"$l" == ""} {
1.7000 + fileevent $s readable [namespace code "doit1 $s"]
1.7001 + set after [after 1000 [namespace code newline]]
1.7002 + }
1.7003 + }
1.7004 + proc doit1 {s} {
1.7005 + variable counter
1.7006 + variable accept
1.7007 +
1.7008 + incr counter
1.7009 + set l [gets $s]
1.7010 + close $s
1.7011 + set accept {}
1.7012 + }
1.7013 + proc producer {} {
1.7014 + variable s
1.7015 + variable writer
1.7016 +
1.7017 + set writer [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
1.7018 + fconfigure $writer -buffering line
1.7019 + puts -nonewline $writer hello
1.7020 + flush $writer
1.7021 + }
1.7022 + proc newline {} {
1.7023 + variable done
1.7024 + variable writer
1.7025 +
1.7026 + puts $writer hello
1.7027 + flush $writer
1.7028 + set done 1
1.7029 + }
1.7030 + producer
1.7031 + variable done
1.7032 + vwait [namespace which -variable done]
1.7033 + close $writer
1.7034 + close $s
1.7035 + after cancel $after
1.7036 + if {$accept != {}} {close $accept}
1.7037 + set counter
1.7038 +} 1
1.7039 +
1.7040 +set path(fooBar) [makeFile {} fooBar]
1.7041 +
1.7042 +test io-55.1 {ChannelEventScriptInvoker: deletion} {fileevent} {
1.7043 + variable x
1.7044 + proc eventScript {fd} {
1.7045 + variable x
1.7046 + close $fd
1.7047 + error "planned error"
1.7048 + set x whoops
1.7049 + }
1.7050 + proc ::bgerror {args} "set [namespace which -variable x] got_error"
1.7051 + set f [open $path(fooBar) w]
1.7052 + fileevent $f writable [namespace code [list eventScript $f]]
1.7053 + variable x not_done
1.7054 + vwait [namespace which -variable x]
1.7055 + set x
1.7056 +} {got_error}
1.7057 +
1.7058 +test io-56.1 {ChannelTimerProc} {testchannelevent} {
1.7059 + set f [open $path(fooBar) w]
1.7060 + puts $f "this is a test"
1.7061 + close $f
1.7062 + set f [open $path(fooBar) r]
1.7063 + testchannelevent $f add readable [namespace code {
1.7064 + read $f 1
1.7065 + incr x
1.7066 + }]
1.7067 + variable x 0
1.7068 + vwait [namespace which -variable x]
1.7069 + vwait [namespace which -variable x]
1.7070 + set result $x
1.7071 + testchannelevent $f set 0 none
1.7072 + after idle [namespace code {set y done}]
1.7073 + variable y
1.7074 + vwait [namespace which -variable y]
1.7075 + close $f
1.7076 + lappend result $y
1.7077 +} {2 done}
1.7078 +
1.7079 +test io-57.1 {buffered data and file events, gets} {fileevent} {
1.7080 + proc accept {sock args} {
1.7081 + variable s2
1.7082 + set s2 $sock
1.7083 + }
1.7084 + set server [socket -server [namespace code accept] 0]
1.7085 + set s [socket 127.0.0.1 [lindex [fconfigure $server -sockname] 2]]
1.7086 + variable s2
1.7087 + vwait [namespace which -variable s2]
1.7088 + update
1.7089 + fileevent $s2 readable [namespace code {lappend result readable}]
1.7090 + puts $s "12\n34567890"
1.7091 + flush $s
1.7092 + variable result [gets $s2]
1.7093 + after 1000 [namespace code {lappend result timer}]
1.7094 + vwait [namespace which -variable result]
1.7095 + lappend result [gets $s2]
1.7096 + vwait [namespace which -variable result]
1.7097 + close $s
1.7098 + close $s2
1.7099 + close $server
1.7100 + set result
1.7101 +} {12 readable 34567890 timer}
1.7102 +test io-57.2 {buffered data and file events, read} {fileevent} {
1.7103 + proc accept {sock args} {
1.7104 + variable s2
1.7105 + set s2 $sock
1.7106 + }
1.7107 + set server [socket -server [namespace code accept] 0]
1.7108 + set s [socket 127.0.0.1 [lindex [fconfigure $server -sockname] 2]]
1.7109 + variable s2
1.7110 + vwait [namespace which -variable s2]
1.7111 + update
1.7112 + fileevent $s2 readable [namespace code {lappend result readable}]
1.7113 + puts -nonewline $s "1234567890"
1.7114 + flush $s
1.7115 + variable result [read $s2 1]
1.7116 + after 1000 [namespace code {lappend result timer}]
1.7117 + vwait [namespace which -variable result]
1.7118 + lappend result [read $s2 9]
1.7119 + vwait [namespace which -variable result]
1.7120 + close $s
1.7121 + close $s2
1.7122 + close $server
1.7123 + set result
1.7124 +} {1 readable 234567890 timer}
1.7125 +
1.7126 +test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc openpipe fileevent} {
1.7127 + set out [open $path(script) w]
1.7128 + puts $out {
1.7129 + puts "normal message from pipe"
1.7130 + puts stderr "error message from pipe"
1.7131 + exit 1
1.7132 + }
1.7133 + proc readit {pipe} {
1.7134 + variable x
1.7135 + variable result
1.7136 + if {[eof $pipe]} {
1.7137 + set x [catch {close $pipe} line]
1.7138 + lappend result catch $line
1.7139 + } else {
1.7140 + gets $pipe line
1.7141 + lappend result gets $line
1.7142 + }
1.7143 + }
1.7144 + close $out
1.7145 + set pipe [open "|[list [interpreter] $path(script)]" r]
1.7146 + fileevent $pipe readable [namespace code [list readit $pipe]]
1.7147 + variable x ""
1.7148 + set result ""
1.7149 + vwait [namespace which -variable x]
1.7150 + list $x $result
1.7151 +} {1 {gets {normal message from pipe} gets {} catch {error message from pipe}}}
1.7152 +
1.7153 +
1.7154 +testConstraint testmainthread [llength [info commands testmainthread]]
1.7155 +test io-59.1 {Thread reference of channels} {testmainthread testchannel} {
1.7156 + # TIP #10
1.7157 + # More complicated tests (like that the reference changes as a
1.7158 + # channel is moved from thread to thread) can be done only in the
1.7159 + # extension which fully implements the moving of channels between
1.7160 + # threads, i.e. 'Threads'. Or we have to extend [testthread] as well.
1.7161 +
1.7162 + set f [open $path(longfile) r]
1.7163 + set result [testchannel mthread $f]
1.7164 + close $f
1.7165 + string equal $result [testmainthread]
1.7166 +} {1}
1.7167 +
1.7168 +
1.7169 +test io-60.1 {writing illegal utf sequences} {openpipe fileevent} {
1.7170 + # This test will hang in older revisions of the core.
1.7171 +
1.7172 + set out [open $path(script) w]
1.7173 + puts $out {
1.7174 + puts [encoding convertfrom identity \xe2]
1.7175 + exit 1
1.7176 + }
1.7177 + proc readit {pipe} {
1.7178 + variable x
1.7179 + variable result
1.7180 + if {[eof $pipe]} {
1.7181 + set x [catch {close $pipe} line]
1.7182 + lappend result catch $line
1.7183 + } else {
1.7184 + gets $pipe line
1.7185 + lappend result gets $line
1.7186 + }
1.7187 + }
1.7188 + close $out
1.7189 + set pipe [open "|[list [interpreter] $path(script)]" r]
1.7190 + fileevent $pipe readable [namespace code [list readit $pipe]]
1.7191 + variable x ""
1.7192 + set result ""
1.7193 + vwait [namespace which -variable x]
1.7194 +
1.7195 + # cut of the remainder of the error stack, especially the filename
1.7196 + set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]]
1.7197 + list $x $result
1.7198 +} {1 {gets {} catch {error writing "stdout": invalid argument}}}
1.7199 +
1.7200 +test io-61.1 {Reset eof state after changing the eof char} -setup {
1.7201 + set datafile [makeFile {} eofchar]
1.7202 + set f [open $datafile w]
1.7203 + fconfigure $f -translation binary
1.7204 + puts -nonewline $f [string repeat "Ho hum\n" 11]
1.7205 + puts $f =
1.7206 + set line [string repeat "Ge gla " 4]
1.7207 + puts -nonewline $f [string repeat [string trimright $line]\n 834]
1.7208 + close $f
1.7209 +} -body {
1.7210 + set f [open $datafile r]
1.7211 + fconfigure $f -eofchar =
1.7212 + set res {}
1.7213 + lappend res [read $f; tell $f]
1.7214 + fconfigure $f -eofchar {}
1.7215 + lappend res [read $f 1]
1.7216 + lappend res [read $f; tell $f]
1.7217 + # Any seek zaps the internals into a good state.
1.7218 + #seek $f 0 start
1.7219 + #seek $f 0 current
1.7220 + #lappend res [read $f; tell $f]
1.7221 + close $f
1.7222 + set res
1.7223 +} -cleanup {
1.7224 + removeFile eofchar
1.7225 +} -result {77 = 23431}
1.7226 +
1.7227 +# cleanup
1.7228 +foreach file [list fooBar longfile script output test1 pipe my_script foo \
1.7229 + bar test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] {
1.7230 + removeFile $file
1.7231 +}
1.7232 +cleanupTests
1.7233 +}
1.7234 +namespace delete ::tcl::test::io
1.7235 +return