通讯编程

开发平台：

Visual C++

io.test：源码内容

# -*- tcl -*-
# Functionality covered: operation of all IO commands, and all procedures
# defined in generic/tclIO.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: io.test,v 1.40.2.12 2007/02/12 19:25:42 andreas_kupries Exp $
if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
namespace eval ::tcl::test::io {
namespace import ::tcltest::cleanupTests
namespace import ::tcltest::interpreter
namespace import ::tcltest::makeFile
namespace import ::tcltest::removeFile
namespace import ::tcltest::test
namespace import ::tcltest::testConstraint
namespace import ::tcltest::viewFile
testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]
testConstraint openpipe 1
testConstraint fileevent [llength [info commands fileevent]]
testConstraint fcopy [llength [info commands fcopy]]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
testConstraint largefileSupport 0
# set up a long data file for some of the following tests
set path(longfile) [makeFile {} longfile]
set f [open $path(longfile) w]
fconfigure $f -eofchar {} -translation lf
for { set i 0 } { $i < 100 } { incr i} {
puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef
#123456789abcdef01
#"
}
close $f
set path(cat) [makeFile {
set f stdin
if {$argv != ""} {
set f [open [lindex $argv 0]]
}
fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar x1a
fconfigure stdout -encoding binary -translation lf -buffering none
fileevent $f readable "foo $f"
proc foo {f} {
set x [read $f]
catch {puts -nonewline $x}
if {[eof $f]} {
close $f
exit 0
}
}
vwait forever
} cat]
set thisScript [file join [pwd] [info script]]
proc contents {file} {
set f [open $file]
fconfigure $f -translation binary
set a [read $f]
close $f
return $a
}
test io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} {
# no test, need to cause an async error.
} {}
set path(test1) [makeFile {} test1]
test io-1.6 {Tcl_WriteChars: WriteBytes} {
set f [open $path(test1) w]
fconfigure $f -encoding binary
puts -nonewline $f "au4e4d"
close $f
contents $path(test1)
} "ax4dx00"
test io-1.7 {Tcl_WriteChars: WriteChars} {
set f [open $path(test1) w]
fconfigure $f -encoding shiftjis
puts -nonewline $f "au4e4d"
close $f
contents $path(test1)
} "ax93xe1x00"
set path(test2) [makeFile {} test2]
test io-1.8 {Tcl_WriteChars: WriteChars} {
# This test written for SF bug #506297.
#
# Executing this test without the fix for the referenced bug
# applied to tcl will cause tcl, more specifically WriteChars, to
# go into an infinite loop.
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp
puts -nonewline $f [format %s%c [string repeat " " 4] 12399]
close $f
contents $path(test2)
} " x1b$B$Ox1b(B"
test io-1.9 {Tcl_WriteChars: WriteChars} {
# When closing a channel with an encoding that appends
# escape bytes, check for the case where the escape
# bytes overflow the current IO buffer. The bytes
# should be moved into a new buffer.
set data "1234567890 [format %c 12399]"
set sizes [list]
# With default buffer size
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp
puts -nonewline $f $data
close $f
lappend sizes [file size $path(test2)]
# With buffer size equal to the length
# of the data, the escape bytes would
# go into the next buffer.
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp -buffersize 16
puts -nonewline $f $data
close $f
lappend sizes [file size $path(test2)]
# With buffer size that is large enough
# to hold 1 byte of escaped data, but
# not all 3. This should not write
# the escape bytes to the first buffer
# and then again to the second buffer.
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp -buffersize 17
puts -nonewline $f $data
close $f
lappend sizes [file size $path(test2)]
# With buffer size that can hold 2 out of
# 3 bytes of escaped data.
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp -buffersize 18
puts -nonewline $f $data
close $f
lappend sizes [file size $path(test2)]
# With buffer size that can hold all the
# data and escape bytes.
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp -buffersize 19
puts -nonewline $f $data
close $f
lappend sizes [file size $path(test2)]
set sizes
} {19 19 19 19 19}
test io-2.1 {WriteBytes} {
# loop until all bytes are written
set f [open $path(test1) w]
fconfigure $f -encoding binary -buffersize 16 -translation crlf
puts $f "abcdefghijklmnopqrstuvwxyz"
close $f
contents $path(test1)
} "abcdefghijklmnopqrstuvwxyzrn"
test io-2.2 {WriteBytes: savedLF > 0} {
# After flushing buffer, there was a n left over from the last
# n -> rn expansion. It gets stuck at beginning of this buffer.
set f [open $path(test1) w]
fconfigure $f -encoding binary -buffersize 16 -translation crlf
puts -nonewline $f "123456789012345n12"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "123456789012345r" "123456789012345rn12"]
test io-2.3 {WriteBytes: flush on line} {
# Tcl "line" buffering has weird behavior: if current buffer contains
# a n, entire buffer gets flushed. Logical behavior would be to flush
# only up to the n.
set f [open $path(test1) w]
fconfigure $f -encoding binary -buffering line -translation crlf
puts -nonewline $f "n12"
set x [contents $path(test1)]
close $f
set x
} "rn12"
test io-2.4 {WriteBytes: reset sawLF after each buffer} {
set f [open $path(test1) w]
fconfigure $f -encoding binary -buffering line -translation lf
-buffersize 16
puts -nonewline $f "abcdefgnhijklmnopqrstuvwxyz"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcdefgnhijklmno" "abcdefgnhijklmnopqrstuvwxyz"]
test io-3.1 {WriteChars: compatibility with WriteBytes} {
# loop until all bytes are written
set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffersize 16 -translation crlf
puts $f "abcdefghijklmnopqrstuvwxyz"
close $f
contents $path(test1)
} "abcdefghijklmnopqrstuvwxyzrn"
test io-3.2 {WriteChars: compatibility with WriteBytes: savedLF > 0} {
# After flushing buffer, there was a n left over from the last
# n -> rn expansion. It gets stuck at beginning of this buffer.
set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffersize 16 -translation crlf
puts -nonewline $f "123456789012345n12"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "123456789012345r" "123456789012345rn12"]
test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} {
# Tcl "line" buffering has weird behavior: if current buffer contains
# a n, entire buffer gets flushed. Logical behavior would be to flush
# only up to the n.
set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffering line -translation crlf
puts -nonewline $f "n12"
set x [contents $path(test1)]
close $f
set x
} "rn12"
test io-3.4 {WriteChars: loop over stage buffer} {
# stage buffer maps to more than can be queued at once.
set f [open $path(test1) w]
fconfigure $f -encoding jis0208 -buffersize 16
puts -nonewline $f "\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.5 {WriteChars: saved != 0} {
# Bytes produced by UtfToExternal from end of last channel buffer
# had to be moved to beginning of next channel buffer to preserve
# requested buffersize.
set f [open $path(test1) w]
fconfigure $f -encoding jis0208 -buffersize 17
puts -nonewline $f "\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} {
# One incomplete UTF-8 character at end of staging buffer. Backup
# in src to the beginning of that UTF-8 character and try again.
#
# Translate the first 16 bytes, produce 14 bytes of output, 2 left over
# (first two bytes of uff21 in UTF-8). Given those two bytes try
# translating them again, find that no bytes are read produced, and break
# to outer loop where those two bytes will have the remaining 4 bytes
# (the last byte of uff21 plus the all of uff22) appended.
set f [open $path(test1) w]
fconfigure $f -encoding shiftjis -buffersize 16
puts -nonewline $f "12345678901234uff21uff22"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "12345678901234x82x60" "12345678901234x82x60x82x61"]
test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} {
# When translating UTF-8 to external, the produced bytes went past end
# of the channel buffer. This is done purpose -- we then truncate the
# bytes at the end of the partial character to preserve the requested
# blocksize on flush. The truncated bytes are moved to the beginning
# of the next channel buffer.
set f [open $path(test1) w]
fconfigure $f -encoding jis0208 -buffersize 17
puts -nonewline $f "\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.8 {WriteChars: reset sawLF after each buffer} {
set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffering line -translation lf
-buffersize 16
puts -nonewline $f "abcdefgnhijklmnopqrstuvwxyz"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcdefgnhijklmno" "abcdefgnhijklmnopqrstuvwxyz"]
test io-4.1 {TranslateOutputEOL: lf} {
# search for n
set f [open $path(test1) w]
fconfigure $f -buffering line -translation lf
puts $f "abcde"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcden" "abcden"]
test io-4.2 {TranslateOutputEOL: cr} {
# search for n, replace with r
set f [open $path(test1) w]
fconfigure $f -buffering line -translation cr
puts $f "abcde"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcder" "abcder"]
test io-4.3 {TranslateOutputEOL: crlf} {
# simple case: search for n, replace with r
set f [open $path(test1) w]
fconfigure $f -buffering line -translation crlf
puts $f "abcde"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcdern" "abcdern"]
test io-4.4 {TranslateOutputEOL: crlf} {
# keep storing more bytes in output buffer until output buffer is full.
# We have 13 bytes initially that would turn into 18 bytes. Fill
# dest buffer while (dstEnd < dstMax).
set f [open $path(test1) w]
fconfigure $f -translation crlf -buffersize 16
puts -nonewline $f "1234567nnnnnA"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "1234567rnrnrnrnr" "1234567rnrnrnrnrnA"]
test io-4.5 {TranslateOutputEOL: crlf} {
# Check for overflow of the destination buffer
set f [open $path(test1) w]
fconfigure $f -translation crlf -buffersize 12
puts -nonewline $f "12345678901n456789012345678901234"
close $f
set x [contents $path(test1)]
} "12345678901rn456789012345678901234"
test io-5.1 {CheckFlush: not full} {
set f [open $path(test1) w]
fconfigure $f
puts -nonewline $f "12345678901234567890"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "" "12345678901234567890"]
test io-5.2 {CheckFlush: full} {
set f [open $path(test1) w]
fconfigure $f -buffersize 16
puts -nonewline $f "12345678901234567890"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "1234567890123456" "12345678901234567890"]
test io-5.3 {CheckFlush: not line} {
set f [open $path(test1) w]
fconfigure $f -buffering line
puts -nonewline $f "12345678901234567890"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "" "12345678901234567890"]
test io-5.4 {CheckFlush: line} {
set f [open $path(test1) w]
fconfigure $f -buffering line -translation lf -encoding ascii
puts -nonewline $f "1234567890n1234567890"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "1234567890n1234567890" "1234567890n1234567890"]
test io-5.5 {CheckFlush: none} {
set f [open $path(test1) w]
fconfigure $f -buffering none
puts -nonewline $f "1234567890"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "1234567890" "1234567890"]
test io-6.1 {Tcl_GetsObj: working} {
set f [open $path(test1) w]
puts $f "foonboo"
close $f
set f [open $path(test1)]
set x [gets $f]
close $f
set x
} {foo}
test io-6.2 {Tcl_GetsObj: CheckChannelErrors() != 0} {
# no test, need to cause an async error.
} {}
test io-6.3 {Tcl_GetsObj: how many have we used?} {
# if (bufPtr != NULL) {oldRemoved = bufPtr->nextRemoved}
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f "abcndefg"
close $f
set f [open $path(test1)]
set x [list [tell $f] [gets $f line] [tell $f] [gets $f line] $line]
close $f
set x
} {0 3 5 4 defg}
test io-6.4 {Tcl_GetsObj: encoding == NULL} {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts $f "x81u1234"
close $f
set f [open $path(test1)]
fconfigure $f -translation binary
set x [list [gets $f line] $line]
close $f
set x
} [list 3 "x81x34x00"]
test io-6.5 {Tcl_GetsObj: encoding != NULL} {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts $f "x88xeax92x9a"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis
set x [list [gets $f line] $line]
close $f
set x
} [list 2 "u4e00u4e01"]
set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
append a $a
append a $a
test io-6.6 {Tcl_GetsObj: loop test} {
# if (dst >= dstEnd)
set f [open $path(test1) w]
puts $f $a
puts $f hi
close $f
set f [open $path(test1)]
set x [list [gets $f line] $line]
close $f
set x
} [list 256 $a]
test io-6.7 {Tcl_GetsObj: error in input} {stdio openpipe} {
# if (FilterInputBytes(chanPtr, &gs) != 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
puts -nonewline $f "hinwould"
flush $f
gets $f
fconfigure $f -blocking 0
set x [gets $f line]
close $f
set x
} {-1}
test io-6.8 {Tcl_GetsObj: remember if EOF is seen} {
set f [open $path(test1) w]
puts $f "abcdefx1aghijknwombat"
close $f
set f [open $path(test1)]
fconfigure $f -eofchar x1a
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {6 abcdef -1 {}}
test io-6.9 {Tcl_GetsObj: remember if EOF is seen} {
set f [open $path(test1) w]
puts $f "abcdefghijknwomu001abat"
close $f
set f [open $path(test1)]
fconfigure $f -eofchar x1a
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {11 abcdefghijk 3 wom}
# Comprehensive tests
test io-6.10 {Tcl_GetsObj: lf mode: no chars} {
set f [open $path(test1) w]
close $f
set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line]
close $f
set x
} {-1 {}}
test io-6.11 {Tcl_GetsObj: lf mode: lone n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "n"
close $f
set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {0 {} -1 {}}
test io-6.12 {Tcl_GetsObj: lf mode: lone r} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "r"
close $f
set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 1 "r" -1 ""]
test io-6.13 {Tcl_GetsObj: lf mode: 1 char} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f a
close $f
set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "an"
close $f
set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.15 {Tcl_GetsObj: lf mode: several chars} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcdnefghrijklrnmnop"
close $f
set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 4 "abcd" 10 "efghrijklr" 4 "mnop" -1 ""]
test io-6.16 {Tcl_GetsObj: cr mode: no chars} {
set f [open $path(test1) w]
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line]
close $f
set x
} {-1 {}}
test io-6.17 {Tcl_GetsObj: cr mode: lone n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "n"
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 1 "n" -1 ""]
test io-6.18 {Tcl_GetsObj: cr mode: lone r} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "r"
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {0 {} -1 {}}
test io-6.19 {Tcl_GetsObj: cr mode: 1 char} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f a
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "ar"
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.21 {Tcl_GetsObj: cr mode: several chars} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcdnefghrijklrnmnop"
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 9 "abcdnefgh" 4 "ijkl" 5 "nmnop" -1 ""]
test io-6.22 {Tcl_GetsObj: crlf mode: no chars} {
set f [open $path(test1) w]
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line]
close $f
set x
} {-1 {}}
test io-6.23 {Tcl_GetsObj: crlf mode: lone n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "n"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 1 "n" -1 ""]
test io-6.24 {Tcl_GetsObj: crlf mode: lone r} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "r"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 1 "r" -1 ""]
test io-6.25 {Tcl_GetsObj: crlf mode: rr} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "rr"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 2 "rr" -1 ""]
test io-6.26 {Tcl_GetsObj: crlf mode: rn} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "rn"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" -1 ""]
test io-6.27 {Tcl_GetsObj: crlf mode: 1 char} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f a
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "arn"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.29 {Tcl_GetsObj: crlf mode: several chars} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcdnefghrijklrnmnop"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 14 "abcdnefghrijkl" 4 "mnop" -1 ""]
test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} {
# if (eol >= dstEnd)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345rnabcdefghijklmnoprstuvwxyz"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [testchannel inputbuffered $f]]
close $f
set x
} [list 15 "123456789012345" 15]
test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel openpipe fileevent} {
# (FilterInputBytes() != 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {crlf lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbrn123456789012345r"
fconfigure $f -buffersize 16
set x [gets $f]
fconfigure $f -blocking 0
lappend x [gets $f line] $line [fblocked $f] [testchannel inputbuffered $f]
close $f
set x
} [list "bbbbbbbbbbbbbb" -1 "" 1 16]
test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} {
# not (FilterInputBytes() != 0)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345rn123"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [tell $f] [testchannel inputbuffered $f]]
close $f
set x
} [list 15 "123456789012345" 17 3]
test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} {
# eol still equals dstEnd
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345r"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [eof $f]]
close $f
set x
} [list 16 "123456789012345r" 1]
test io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by n} {
# not (*eol == 'n')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345rabcdrnefg"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [tell $f]]
close $f
set x
} [list 20 "123456789012345rabcd" 22]
test io-6.35 {Tcl_GetsObj: auto mode: no chars} {
set f [open $path(test1) w]
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line]
close $f
set x
} {-1 {}}
test io-6.36 {Tcl_GetsObj: auto mode: lone n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "n"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" -1 ""]
test io-6.37 {Tcl_GetsObj: auto mode: lone r} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "r"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" -1 ""]
test io-6.38 {Tcl_GetsObj: auto mode: rr} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "rr"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" 0 "" -1 ""]
test io-6.39 {Tcl_GetsObj: auto mode: rn} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "rn"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" -1 ""]
test io-6.40 {Tcl_GetsObj: auto mode: 1 char} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f a
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "arn"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.42 {Tcl_GetsObj: auto mode: several chars} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcdnefghrijklrnmnop"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
lappend x [gets $f line] $line [gets $f line] $line [gets $f line] $line
close $f
set x
} [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""]
test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} {
# if (chanPtr->flags & INPUT_SAW_CR)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbbn123456789abcdefr"
fconfigure $f -buffersize 16
set x [list [gets $f]]
fconfigure $f -blocking 0
lappend x [gets $f line] $line [testchannel queuedcr $f]
fconfigure $f -blocking 1
puts -nonewline $f "nabcdrefgx1a"
lappend x [gets $f line] $line [testchannel queuedcr $f]
lappend x [gets $f line] $line
close $f
set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe fileevent} {
# not (*eol == 'n')
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbbn123456789abcdefr"
fconfigure $f -buffersize 16
set x [list [gets $f]]
fconfigure $f -blocking 0
lappend x [gets $f line] $line [testchannel queuedcr $f]
fconfigure $f -blocking 1
puts -nonewline $f "abcdrefgx1a"
lappend x [gets $f line] $line [testchannel queuedcr $f]
lappend x [gets $f line] $line
close $f
set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel openpipe fileevent} {
# Tcl_ExternalToUtf()
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
fconfigure $f -encoding unicode
puts -nonewline $f "bbbbbbbbbbbbbbbn123456789abcdefr"
fconfigure $f -buffersize 16
gets $f
fconfigure $f -blocking 0
set x [list [gets $f line] $line [testchannel queuedcr $f]]
fconfigure $f -blocking 1
puts -nonewline $f "nabcdrefg"
lappend x [gets $f line] $line [testchannel queuedcr $f]
close $f
set x
} [list 15 "123456789abcdef" 1 4 "abcd" 0]
test io-6.46 {Tcl_GetsObj: input saw cr, followed by just n should give eof} {stdio testchannel openpipe fileevent} {
# memmove()
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbbn123456789abcdefr"
fconfigure $f -buffersize 16
gets $f
fconfigure $f -blocking 0
set x [list [gets $f line] $line [testchannel queuedcr $f]]
fconfigure $f -blocking 1
puts -nonewline $f "nx1a"
lappend x [gets $f line] $line [testchannel queuedcr $f]
close $f
set x
} [list 15 "123456789abcdef" 1 -1 "" 0]
test io-6.47 {Tcl_GetsObj: auto mode: r at end of buffer, peek for n} {testchannel} {
# (eol == dstEnd)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345rnabcdefghijklmnopq"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto -buffersize 16
set x [list [gets $f] [testchannel inputbuffered $f]]
close $f
set x
} [list "123456789012345" 15]
test io-6.48 {Tcl_GetsObj: auto mode: r at end of buffer, no more avail} {testchannel} {
# PeekAhead() did not get any, so (eol >= dstEnd)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345r"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto -buffersize 16
set x [list [gets $f] [testchannel queuedcr $f]]
close $f
set x
} [list "123456789012345" 1]
test io-6.49 {Tcl_GetsObj: auto mode: r followed by n} {testchannel} {
# if (*eol == 'n') {skip++}
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456rn78901"
close $f
set f [open $path(test1)]
set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
close $f
set x
} [list "123456" 0 8 "78901"]
test io-6.50 {Tcl_GetsObj: auto mode: r not followed by n} {testchannel} {
# not (*eol == 'n')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456r78901"
close $f
set f [open $path(test1)]
set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
close $f
set x
} [list "123456" 0 7 "78901"]
test io-6.51 {Tcl_GetsObj: auto mode: n} {
# else if (*eol == 'n') {goto gotoeol;}
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456n78901"
close $f
set f [open $path(test1)]
set x [list [gets $f] [tell $f] [gets $f]]
close $f
set x
} [list "123456" 7 "78901"]
test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} {
# if (eof != NULL)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456x1ak9012345r"
close $f
set f [open $path(test1)]
fconfigure $f -eofchar x1a
set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
close $f
set x
} [list "123456" 0 6 ""]
test io-6.53 {Tcl_GetsObj: device EOF} {
# didn't produce any bytes
set f [open $path(test1) w]
close $f
set f [open $path(test1)]
set x [list [gets $f line] $line [eof $f]]
close $f
set x
} {-1 {} 1}
test io-6.54 {Tcl_GetsObj: device EOF} {
# got some bytes before EOF.
set f [open $path(test1) w]
puts -nonewline $f abc
close $f
set f [open $path(test1)]
set x [list [gets $f line] $line [eof $f]]
close $f
set x
} {3 abc 1}
test io-6.55 {Tcl_GetsObj: overconverted} {
# Tcl_ExternalToUtf(), make sure state updated
set f [open $path(test1) w]
fconfigure $f -encoding iso2022-jp
puts $f "thereu4e00oknu4e01more bytesnhere"
close $f
set f [open $path(test1)]
fconfigure $f -encoding iso2022-jp
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 8 "thereu4e00ok" 11 "u4e01more bytes" 4 "here"]
test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio openpipe fileevent} {
update
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -buffering none
puts -nonewline $f "foobar"
fconfigure $f -blocking 0
variable x {}
after 500 [namespace code { lappend x timeout }]
fileevent $f readable [namespace code { lappend x [gets $f] }]
vwait [namespace which -variable x]
vwait [namespace which -variable x]
fconfigure $f -blocking 1
puts -nonewline $f "bazn"
after 500 [namespace code { lappend x timeout }]
fconfigure $f -blocking 0
vwait [namespace which -variable x]
vwait [namespace which -variable x]
close $f
set x
} {{} timeout foobarbaz timeout}
test io-7.1 {FilterInputBytes: split up character at end of buffer} {
# (result == TCL_CONVERT_MULTIBYTE)
set f [open $path(test1) w]
fconfigure $f -encoding shiftjis
puts $f "1234567890123uff10uff11uff12uff13uff14nend"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis -buffersize 16
set x [gets $f]
close $f
set x
} "1234567890123uff10uff11uff12uff13uff14"
test io-7.2 {FilterInputBytes: split up character in middle of buffer} {
# (bufPtr->nextAdded < bufPtr->bufLength)
set f [open $path(test1) w]
fconfigure $f -encoding binary
puts -nonewline $f "1234567890n123x82x4fx82x50x82"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis
set x [list [gets $f line] $line [eof $f]]
close $f
set x
} [list 10 "1234567890" 0]
test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} {
set f [open $path(test1) w]
fconfigure $f -encoding binary
puts -nonewline $f "1234567890123x82x4fx82x50x82"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis
set x [list [gets $f line] $line]
lappend x [tell $f] [testchannel inputbuffered $f] [eof $f]
lappend x [gets $f line] $line
close $f
set x
} [list 15 "1234567890123uff10uff11" 18 0 1 -1 ""]
test io-7.4 {FilterInputBytes: recover from split up character} {stdio openpipe fileevent} {
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -encoding binary -buffering none
puts -nonewline $f "1234567890123x82x4fx82x50x82"
fconfigure $f -encoding shiftjis -blocking 0
fileevent $f read [namespace code "ready $f"]
variable x {}
proc ready {f} {
variable x
lappend x [gets $f line] $line [fblocked $f]
}
vwait [namespace which -variable x]
fconfigure $f -encoding binary -blocking 1
puts $f "x51x82x52"
fconfigure $f -encoding shiftjis
vwait [namespace which -variable x]
close $f
set x
} [list -1 "" 1 17 "1234567890123uff10uff11uff12uff13" 0]
test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} {
# (bufPtr->nextPtr == NULL)
set f [open $path(test1) w]
fconfigure $f -encoding ascii -translation lf
puts -nonewline $f "123456789012345rn2345678"
close $f
set f [open $path(test1)]
fconfigure $f -encoding ascii -translation auto -buffersize 16
# here
gets $f
set x [testchannel inputbuffered $f]
close $f
set x
} "7"
test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel openpipe fileevent} {
# not (bufPtr->nextPtr == NULL)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation lf -encoding ascii -buffering none
puts -nonewline $f "123456789012345rnbcdefghijklmnopqrstuvwxyz"
variable x {}
fileevent $f read [namespace code "ready $f"]
proc ready {f} {
variable x
lappend x [gets $f line] $line [testchannel inputbuffered $f]
}
fconfigure $f -encoding unicode -buffersize 16 -blocking 0
vwait [namespace which -variable x]
fconfigure $f -translation auto -encoding ascii -blocking 1
# here
vwait [namespace which -variable x]
close $f
set x
} [list -1 "" 42 15 "123456789012345" 25]
test io-8.3 {PeekAhead: no cached data available} {stdio testchannel openpipe fileevent} {
# (bytesLeft == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary}
puts -nonewline $f "abcdefghijklmnor"
flush $f
set x [list [gets $f line] $line [testchannel queuedcr $f]]
close $f
set x
} [list 15 "abcdefghijklmno" 1]
set a "123456789012345678901234567890"
append a "123456789012345678901234567890"
append a "1234567890123456789012345678901"
test io-8.4 {PeekAhead: cached data available in this buffer} {
# not (bytesLeft == 0)
set f [open $path(test1) w+]
fconfigure $f -translation binary
puts $f "${a}rnabcdef"
close $f
set f [open $path(test1)]
fconfigure $f -encoding binary -translation auto
# "${a}r" was converted in one operation (because ENCODING_LINESIZE
# is 30). To check if "n" follows, calls PeekAhead and determines
# that cached data is available in buffer w/o having to call driver.
set x [gets $f]
close $f
set x
} $a
unset a
test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe fileevent} {
# (bufPtr->nextAdded < bufPtr->length)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary}
puts -nonewline $f "abcdefghijklmnor"
flush $f
# here
set x [list [gets $f line] $line [testchannel queuedcr $f]]
close $f
set x
} {15 abcdefghijklmno 1}
test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe fileevent} {
# ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary} -buffersize 16
puts -nonewline $f "abcdefghijklmnor"
flush $f
# here
set x [list [gets $f line] $line [testchannel queuedcr $f]]
close $f
set x
} {15 abcdefghijklmno 1}
test io-8.7 {PeekAhead: cleanup} {stdio testchannel openpipe fileevent} {
# Make sure bytes are removed from buffer.
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary} -buffering none
puts -nonewline $f "abcdefghijklmnor"
# here
set x [list [gets $f line] $line [testchannel queuedcr $f]]
puts -nonewline $f "x1a"
lappend x [gets $f line] $line
close $f
set x
} {15 abcdefghijklmno 1 -1 {}}
test io-9.1 {CommonGetsCleanup} {
} {}
test io-10.1 {Tcl_ReadChars: CheckChannelErrors} {
# no test, need to cause an async error.
} {}
test io-10.2 {Tcl_ReadChars: loop until enough copied} {
# one time
# for (copied = 0; (unsigned) toRead > 0; )
set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
set f [open $path(test1)]
set x [read $f 5]
close $f
set x
} {abcde}
test io-10.3 {Tcl_ReadChars: loop until enough copied} {
# multiple times
# for (copied = 0; (unsigned) toRead > 0; )
set f [open $path(test1) w]
puts $f abcdefghijklmnopqrstuvwxyz
close $f
set f [open $path(test1)]
fconfigure $f -buffersize 16
# here
set x [read $f 19]
close $f
set x
} {abcdefghijklmnopqrs}
test io-10.4 {Tcl_ReadChars: no more in channel buffer} {
# (copiedNow < 0)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
# here
set x [read $f 1000]
close $f
set x
} {abcdefghijkl}
test io-10.5 {Tcl_ReadChars: stop on EOF} {
# (chanPtr->flags & CHANNEL_EOF)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
# here
set x [read $f 1000]
close $f
set x
} {abcdefghijkl}
test io-11.1 {ReadBytes: want to read a lot} {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
fconfigure $f -encoding binary
# here
set x [read $f 1000]
close $f
set x
} {abcdefghijkl}
test io-11.2 {ReadBytes: want to read all} {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
fconfigure $f -encoding binary
# here
set x [read $f]
close $f
set x
} {abcdefghijkl}
test io-11.3 {ReadBytes: allocate more space} {
# (toRead > length - offset - 1)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijklmnopqrstuvwxyz
close $f
set f [open $path(test1)]
fconfigure $f -buffersize 16 -encoding binary
# here
set x [read $f]
close $f
set x
} {abcdefghijklmnopqrstuvwxyz}
test io-11.4 {ReadBytes: EOF char found} {
# (TranslateInputEOL() != 0)
set f [open $path(test1) w]
puts $f abcdefghijklmnopqrstuvwxyz
close $f
set f [open $path(test1)]
fconfigure $f -eofchar m -encoding binary
# here
set x [list [read $f] [eof $f] [read $f] [eof $f]]
close $f
set x
} [list "abcdefghijkl" 1 "" 1]
test io-12.1 {ReadChars: want to read a lot} {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
# here
set x [read $f 1000]
close $f
set x
} {abcdefghijkl}
test io-12.2 {ReadChars: want to read all} {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
# here
set x [read $f]
close $f
set x
} {abcdefghijkl}
test io-12.3 {ReadChars: allocate more space} {
# (toRead > length - offset - 1)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijklmnopqrstuvwxyz
close $f
set f [open $path(test1)]
fconfigure $f -buffersize 16
# here
set x [read $f]
close $f
set x
} {abcdefghijklmnopqrstuvwxyz}
test io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} {
# (srcRead == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -encoding binary -buffering none -buffersize 16
puts -nonewline $f "123456789012345x96"
fconfigure $f -encoding shiftjis -blocking 0
fileevent $f read [namespace code "ready $f"]
proc ready {f} {
variable x
lappend x [read $f] [testchannel inputbuffered $f]
}
variable x {}
fconfigure $f -encoding shiftjis
vwait [namespace which -variable x]
fconfigure $f -encoding binary -blocking 1
puts -nonewline $f "x7b"
after 500 ;# Give the cat process time to catch up
fconfigure $f -encoding shiftjis -blocking 0
vwait [namespace which -variable x]
close $f
set x
} [list "123456789012345" 1 "u672c" 0]
test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe fileevent} {
set path(test1) [makeFile {
fconfigure stdout -encoding binary -buffering none
gets stdin; puts -nonewline "xe7"
gets stdin; puts -nonewline "x89"
gets stdin; puts -nonewline "xa6"
} test1]
set f [open "|[list [interpreter] $path(test1)]" r+]
fileevent $f readable [namespace code {
lappend x [read $f]
if {[eof $f]} {
lappend x eof
}
}]
puts $f "go1"
flush $f
fconfigure $f -blocking 0 -encoding utf-8
variable x {}
vwait [namespace which -variable x]
after 500 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
puts $f "go2"
flush $f
vwait [namespace which -variable x]
after 500 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
puts $f "go3"
flush $f
vwait [namespace which -variable x]
vwait [namespace which -variable x]
lappend x [catch {close $f} msg] $msg
set x
} "{} timeout {} timeout u7266 {} eof 0 {}"
test io-13.1 {TranslateInputEOL: cr mode} {} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcdrdefr"
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [read $f]
close $f
set x
} "abcdndefn"
test io-13.2 {TranslateInputEOL: crlf mode} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcdrndefrn"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcdndefn"
test io-13.3 {TranslateInputEOL: crlf mode: naked cr} {
# (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcdrndefr"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcdndefr"
test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not n} {
# (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcdrndefrfgh"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcdndefrfgh"
test io-13.5 {TranslateInputEOL: crlf mode: naked lf} {
# (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcdrndefnfgh"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcdndefnfgh"
test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel openpipe fileevent} {
# (chanPtr->flags & INPUT_SAW_CR)
# This test may fail on slower machines.
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -blocking 0 -buffering none -translation {auto lf}
fileevent $f read [namespace code "ready $f"]
proc ready {f} {
variable x
lappend x [read $f] [testchannel queuedcr $f]
}
variable x {}
variable y {}
puts -nonewline $f "abcdefghjr"
after 500 [namespace code {set y ok}]
vwait [namespace which -variable y]
puts -nonewline $f "n01234"
after 500 [namespace code {set y ok}]
vwait [namespace which -variable y]
close $f
set x
} [list "abcdefghjn" 1 "01234" 0]
test io-13.7 {TranslateInputEOL: auto mode: naked r} {testchannel openpipe} {
# (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcdr"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [read $f] [testchannel queuedcr $f]]
close $f
set x
} [list "abcdn" 1]
test io-13.8 {TranslateInputEOL: auto mode: rn} {
# (*src == 'n')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcdrndef"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [read $f]
close $f
set x
} "abcdndef"
test io-13.9 {TranslateInputEOL: auto mode: r followed by not n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcdrdef"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [read $f]
close $f
set x
} "abcdndef"
test io-13.10 {TranslateInputEOL: auto mode: n} {
# not (*src == 'r')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcdndef"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [read $f]
close $f
set x
} "abcdndef"
test io-13.11 {TranslateInputEOL: EOF char} {
# (*chanPtr->inEofChar != '')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcdndefgh"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto -eofchar e
set x [read $f]
close $f
set x
} "abcdnd"
test io-13.12 {TranslateInputEOL: find EOF char in src} {
# (*chanPtr->inEofChar != '')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "rnrnrnabrnrndefrnrnrn"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto -eofchar e
set x [read $f]
close $f
set x
} "nnnabnnd"
# Test standard handle management. The functions tested are
# Tcl_SetStdChannel and Tcl_GetStdChannel. Incidentally we are
# also testing channel table management.
if {[info commands testchannel] != ""} {
if {$tcl_platform(platform) == "macintosh"} {
set consoleFileNames [list console0 console1 console2]
} else {
set consoleFileNames [lsort [testchannel open]]
}
} else {
# just to avoid an error
set consoleFileNames [list]
}
test io-14.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} {testchannel} {
set l ""
lappend l [fconfigure stdin -buffering]
lappend l [fconfigure stdout -buffering]
lappend l [fconfigure stderr -buffering]
lappend l [lsort [testchannel open]]
set l
} [list line line none $consoleFileNames]
test io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} {
interp create x
set l ""
lappend l [x eval {fconfigure stdin -buffering}]
lappend l [x eval {fconfigure stdout -buffering}]
lappend l [x eval {fconfigure stderr -buffering}]
interp delete x
set l
} {line line none}
set path(test3) [makeFile {} test3]
test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec openpipe} {
set f [open $path(test1) w]
puts -nonewline $f {
close stdin
close stdout
close stderr
set f [}
puts $f [list open $path(test1) r]]
puts $f "set f2 [[list open $path(test2) w]]"
puts $f "set f3 [[list open $path(test3) w]]"
puts $f { puts stdout [gets stdin]
puts stdout out
puts stderr err
close $f
close $f2
close $f3
}
close $f
set result [exec [interpreter] $path(test1)]
set f [open $path(test2) r]
set f2 [open $path(test3) r]
lappend result [read $f] [read $f2]
close $f
close $f2
set result
} {{
out
} {err
}}
# This test relies on the fact that the smallest available fd is used first.
test io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec unixOnly} {
set f [open $path(test1) w]
puts -nonewline $f { close stdin
close stdout
close stderr
set f [}
puts $f [list open $path(test1) r]]
puts $f "set f2 [[list open $path(test2) w]]"
puts $f "set f3 [[list open $path(test3) w]]"
puts $f { puts stdout [gets stdin]
puts stdout $f2
puts stderr $f3
close $f
close $f2
close $f3
}
close $f
set result [exec [interpreter] $path(test1)]
set f [open $path(test2) r]
set f2 [open $path(test3) r]
lappend result [read $f] [read $f2]
close $f
close $f2
set result
} {{ close stdin
file1
} {file2
}}
catch {interp delete z}
test io-14.5 {Tcl_GetChannel: stdio name translation} {
interp create z
eof stdin
catch {z eval flush stdin} msg1
catch {z eval close stdin} msg2
catch {z eval flush stdin} msg3
set result [list $msg1 $msg2 $msg3]
interp delete z
set result
} {{channel "stdin" wasn't opened for writing} {} {can not find channel named "stdin"}}
test io-14.6 {Tcl_GetChannel: stdio name translation} {
interp create z
eof stdout
catch {z eval flush stdout} msg1
catch {z eval close stdout} msg2
catch {z eval flush stdout} msg3
set result [list $msg1 $msg2 $msg3]
interp delete z
set result
} {{} {} {can not find channel named "stdout"}}
test io-14.7 {Tcl_GetChannel: stdio name translation} {
interp create z
eof stderr
catch {z eval flush stderr} msg1
catch {z eval close stderr} msg2
catch {z eval flush stderr} msg3
set result [list $msg1 $msg2 $msg3]
interp delete z
set result
} {{} {} {can not find channel named "stderr"}}
set path(script) [makeFile {} script]
test io-14.8 {reuse of stdio special channels} {stdio openpipe} {
file delete $path(script)
file delete $path(test1)
set f [open $path(script) w]
puts -nonewline $f {
close stderr
set f [}
puts $f [list open $path(test1) w]]
puts -nonewline $f {
puts stderr hello
close $f
set f [}
puts $f [list open $path(test1) r]]
puts $f {
puts [gets $f]
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
set c [gets $f]
close $f
set c
} hello
test io-14.9 {reuse of stdio special channels} {stdio openpipe fileevent} {
file delete $path(script)
file delete $path(test1)
set f [open $path(script) w]
puts $f {
array set path [lindex $argv 0]
set f [open $path(test1) w]
puts $f hello
close $f
close stderr
set f [open "|[list [info nameofexecutable] $path(cat) $path(test1)]" r]
puts [gets $f]
}
close $f
set f [open "|[list [interpreter] $path(script) [array get path]]" r]
set c [gets $f]
close $f
# Added delay to give Windows time to stop the spawned process and clean
# up its grip on the file test1. Added delete as proper test cleanup.
# The failing tests were 18.1 and 18.2 as first re-users of file "test1".
after 10000
file delete $path(script)
file delete $path(test1)
set c
} hello
test io-15.1 {Tcl_CreateCloseHandler} {
} {}
test io-16.1 {Tcl_DeleteCloseHandler} {
} {}
# Test channel table management. The functions tested are
# GetChannelTable, DeleteChannelTable, Tcl_RegisterChannel,
# Tcl_UnregisterChannel, Tcl_GetChannel and Tcl_CreateChannel.
#
# These functions use "eof stdin" to ensure that the standard
# channels are added to the channel table of the interpreter.
test io-17.1 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} {
set l1 [testchannel refcount stdin]
eof stdin
interp create x
set l ""
lappend l [expr [testchannel refcount stdin] - $l1]
x eval {eof stdin}
lappend l [expr [testchannel refcount stdin] - $l1]
interp delete x
lappend l [expr [testchannel refcount stdin] - $l1]
set l
} {0 1 0}
test io-17.2 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} {
set l1 [testchannel refcount stdout]
eof stdin
interp create x
set l ""
lappend l [expr [testchannel refcount stdout] - $l1]
x eval {eof stdout}
lappend l [expr [testchannel refcount stdout] - $l1]
interp delete x
lappend l [expr [testchannel refcount stdout] - $l1]
set l
} {0 1 0}
test io-17.3 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} {
set l1 [testchannel refcount stderr]
eof stdin
interp create x
set l ""
lappend l [expr [testchannel refcount stderr] - $l1]
x eval {eof stderr}
lappend l [expr [testchannel refcount stderr] - $l1]
interp delete x
lappend l [expr [testchannel refcount stderr] - $l1]
set l
} {0 1 0}
test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
file delete $path(test1)
set l ""
set f [open $path(test1) w]
lappend l [lindex [testchannel info $f] 15]
close $f
if {[catch {lindex [testchannel info $f] 15} msg]} {
lappend l $msg
} else {
lappend l "very broken: $f found after being closed"
}
string compare [string tolower $l]
[list 1 [format "can not find channel named "%s"" $f]]
} 0
test io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
file delete $path(test1)
set l ""
set f [open $path(test1) w]
lappend l [lindex [testchannel info $f] 15]
interp create x
interp share "" $f x
lappend l [lindex [testchannel info $f] 15]
x eval close $f
lappend l [lindex [testchannel info $f] 15]
interp delete x
lappend l [lindex [testchannel info $f] 15]
close $f
if {[catch {lindex [testchannel info $f] 15} msg]} {
lappend l $msg
} else {
lappend l "very broken: $f found after being closed"
}
string compare [string tolower $l]
[list 1 2 1 1 [format "can not find channel named "%s"" $f]]
} 0
test io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
file delete $path(test1)
set l ""
set f [open $path(test1) w]
lappend l [lindex [testchannel info $f] 15]
interp create x
interp share "" $f x
lappend l [lindex [testchannel info $f] 15]
interp delete x
lappend l [lindex [testchannel info $f] 15]
close $f
if {[catch {lindex [testchannel info $f] 15} msg]} {
lappend l $msg
} else {
lappend l "very broken: $f found after being closed"
}
string compare [string tolower $l]
[list 1 2 1 [format "can not find channel named "%s"" $f]]
} 0
test io-19.1 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} {
eof stdin
} 0
test io-19.2 {testing Tcl_GetChannel, user opened handle} {
file delete $path(test1)
set f [open $path(test1) w]
set x [eof $f]
close $f
set x
} 0
test io-19.3 {Tcl_GetChannel, channel not found} {
list [catch {eof file34} msg] $msg
} {1 {can not find channel named "file34"}}
test io-19.4 {Tcl_CreateChannel, insertion into channel table} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
set l ""
lappend l [eof $f]
close $f
if {[catch {lindex [testchannel info $f] 15} msg]} {
lappend l $msg
} else {
lappend l "very broken: $f found after being closed"
}
string compare [string tolower $l]
[list 0 [format "can not find channel named "%s"" $f]]
} 0
test io-20.1 {Tcl_CreateChannel: initial settings} {
set a [open $path(test2) w]
set old [encoding system]
encoding system ascii
set f [open $path(test1) w]
set x [fconfigure $f -encoding]
close $f
encoding system $old
close $a
set x
} {ascii}
test io-20.2 {Tcl_CreateChannel: initial settings} {pcOnly} {
set f [open $path(test1) w+]
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
} [list [list x1a ""] {auto crlf}]
test io-20.3 {Tcl_CreateChannel: initial settings} {unixOnly} {
set f [open $path(test1) w+]
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
} {{{} {}} {auto lf}}
test io-20.4 {Tcl_CreateChannel: initial settings} {macOnly} {
set f [open $path(test1) w+]
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
} {{{} {}} {auto cr}}
set path(stdout) [makeFile {} stdout]
test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio openpipe} {
set f [open $path(script) w]
puts -nonewline $f {
close stdout
set f1 [}
puts $f [list open $path(stdout) w]]
puts $f {
fconfigure $f1 -buffersize 777
puts stderr [fconfigure stdout -buffersize]
}
close $f
set f [open "|[list [interpreter] $path(script)]"]
catch {close $f} msg
set msg
} {777}
test io-21.1 {CloseChannelsOnExit} {
} {}
# Test management of attributes associated with a channel, such as
# its default translation, its name and type, etc. The functions
# tested in this group are Tcl_GetChannelName,
# Tcl_GetChannelType and Tcl_GetChannelFile. Tcl_GetChannelInstanceData
# not tested because files do not use the instance data.
test io-22.1 {Tcl_GetChannelMode} {
# Not used anywhere in Tcl.
} {}
test io-23.1 {Tcl_GetChannelName} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
set n [testchannel name $f]
close $f
string compare $n $f
} 0
test io-24.1 {Tcl_GetChannelType} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
set t [testchannel type $f]
close $f
string compare $t file
} 0
test io-25.1 {Tcl_GetChannelHandle, input} {testchannel} {
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
puts $f "1234567890n098765432"
close $f
set f [open $path(test1) r]
gets $f
set l ""
lappend l [testchannel inputbuffered $f]
lappend l [tell $f]
close $f
set l
} {10 11}
test io-25.2 {Tcl_GetChannelHandle, output} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [tell $f]
flush $f
lappend l [testchannel outputbuffered $f]
lappend l [tell $f]
close $f
file delete $path(test1)
set l
} {6 6 0 6}
test io-26.1 {Tcl_GetChannelInstanceData} {stdio openpipe} {
# "pid" command uses Tcl_GetChannelInstanceData
# Don't care what pid is (but must be a number), just want to exercise it.
set f [open "|[list [interpreter] << exit]"]
expr [pid $f]
close $f
} {}
# Test flushing. The functions tested here are FlushChannel.
test io-27.1 {FlushChannel, no output buffered} {
file delete $path(test1)
set f [open $path(test1) w]
flush $f
set s [file size $path(test1)]
close $f
set s
} 0
test io-27.2 {FlushChannel, some output buffered} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set l ""
puts $f hello
lappend l [file size $path(test1)]
flush $f
lappend l [file size $path(test1)]
close $f
lappend l [file size $path(test1)]
set l
} {0 6 6}
test io-27.3 {FlushChannel, implicit flush on close} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set l ""
puts $f hello
lappend l [file size $path(test1)]
close $f
lappend l [file size $path(test1)]
set l
} {0 6}
test io-27.4 {FlushChannel, implicit flush when buffer fills} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
fconfigure $f -buffersize 60
set l ""
lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
puts $f hello
}
lappend l [file size $path(test1)]
flush $f
lappend l [file size $path(test1)]
close $f
set l
} {0 60 72}
test io-27.5 {FlushChannel, implicit flush when buffer fills and on close}
{unixOrPc} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffersize 60 -eofchar {}
set l ""
lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
puts $f hello
}
lappend l [file size $path(test1)]
close $f
lappend l [file size $path(test1)]
set l
} {0 60 72}
set path(pipe) [makeFile {} pipe]
set path(output) [makeFile {} output]
test io-27.6 {FlushChannel, async flushing, async close}
{stdio asyncPipeClose openpipe} {
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f "set f [[list open $path(output) w]]"
puts $f {
fconfigure $f -translation lf -buffering none -eofchar {}
while {![eof stdin]} {
after 20
puts -nonewline $f [read stdin 1024]
}
close $f
}
close $f
set x 01234567890123456789012345678901
for {set i 0} {$i < 11} {incr i} {
set x "$x$x"
}
set f [open $path(output) w]
close $f
set f [open "|[list [interpreter] $path(pipe)]" w]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
set counter 0
while {([file size $path(output)] < 65536) && ($counter < 1000)} {
incr counter
after 20
update
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
} ok
# Tests closing a channel. The functions tested are CloseChannel and Tcl_Close.
test io-28.1 {CloseChannel called when all references are dropped} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
interp create x
interp share "" $f x
set l ""
lappend l [testchannel refcount $f]
x eval close $f
interp delete x
lappend l [testchannel refcount $f]
close $f
set l
} {2 1}
test io-28.2 {CloseChannel called when all references are dropped} {
file delete $path(test1)
set f [open $path(test1) w]
interp create x
interp share "" $f x
puts -nonewline $f abc
close $f
x eval puts $f def
x eval close $f
interp delete x
set f [open $path(test1) r]
set l [gets $f]
close $f
set l
} abcdef
test io-28.3 {CloseChannel, not called before output queue is empty}
{stdio asyncPipeClose nonPortable openpipe} {
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f {
# Need to not have eof char appended on close, because the other
# side of the pipe already closed, so that writing would cause an
# error "invalid file".
fconfigure stdout -eofchar {}
fconfigure stderr -eofchar {}
set f [open $path(output) w]
fconfigure $f -translation lf -buffering none
for {set x 0} {$x < 20} {incr x} {
after 20
puts -nonewline $f [read stdin 1024]
}
close $f
}
close $f
set x 01234567890123456789012345678901
for {set i 0} {$i < 11} {incr i} {
set x "$x$x"
}
set f [open $path(output) w]
close $f
set f [open "|[list [interpreter] pipe]" r+]
fconfigure $f -blocking off -eofchar {}
puts -nonewline $f $x
close $f
set counter 0
while {([file size $path(output)] < 20480) && ($counter < 1000)} {
incr counter
after 20
update
}
if {$counter == 1000} {
set result probably_broken
} else {
set result ok
}
} ok
test io-28.4 {Tcl_Close} {testchannel} {
file delete $path(test1)
set l ""
lappend l [lsort [testchannel open]]
set f [open $path(test1) w]
lappend l [lsort [testchannel open]]
close $f
lappend l [lsort [testchannel open]]
set x [list $consoleFileNames
[lsort [eval list $consoleFileNames $f]]
$consoleFileNames]
string compare $l $x
} 0
test io-28.5 {Tcl_Close vs standard handles} {stdio unixOnly testchannel openpipe} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
close stdin
puts [testchannel open]
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
set l [gets $f]
close $f
set l
} {file1 file2}
test io-29.1 {Tcl_WriteChars, channel not writable} {
list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.2 {Tcl_WriteChars, empty string} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -eofchar {}
puts -nonewline $f ""
close $f
file size $path(test1)
} 0
test io-29.3 {Tcl_WriteChars, nonempty string} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -eofchar {}
puts -nonewline $f hello
close $f
file size $path(test1)
} 5
test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering full -eofchar {}
puts $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
flush $f
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
close $f
set l
} {6 0 0 6}
test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering line -eofchar {}
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
close $f
set l
} {5 0 0 11}
test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering none -eofchar {}
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
close $f
set l
} {0 5 0 11}
test io-29.7 {Tcl_Flush, full buffering} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering full -eofchar {}
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
flush $f
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
close $f
set l
} {5 0 11 0 0 11}
test io-29.8 {Tcl_Flush, full buffering} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering line
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
flush $f
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
flush $f
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
close $f
set l
} {5 0 0 5 0 11 0 11}
test io-29.9 {Tcl_Flush, channel not writable} {
list [catch {flush stdin} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.10 {Tcl_WriteChars, looping and buffering} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
set f2 [open $path(longfile) r]
for {set x 0} {$x < 10} {incr x} {
puts $f1 [gets $f2]
}
close $f2
close $f1
file size $path(test1)
} 387
test io-29.11 {Tcl_WriteChars, no newline, implicit flush} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -eofchar {}
set f2 [open $path(longfile) r]
for {set x 0} {$x < 10} {incr x} {
puts -nonewline $f1 [gets $f2]
}
close $f1
close $f2
file size $path(test1)
} 377
test io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 "set f1 [[list open $path(longfile) r]]"
puts $f1 {
for {set x 0} {$x < 10} {incr x} {
puts [gets $f1]
}
}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r]
set f2 [open $path(longfile) r]
set y ok
for {set x 0} {$x < 10} {incr x} {
set l1 [gets $f1]
set l2 [gets $f2]
if {"$l1" != "$l2"} {
set y broken
}
}
close $f1
close $f2
set y
} ok
test io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio openpipe} {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
puts [gets stdin]
puts [gets stdin]
}
close $f1
set y ok
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f1 -buffering line
set f2 [open $path(longfile) r]
set line [gets $f2]
puts $f1 $line
set backline [gets $f1]
if {"$line" != "$backline"} {
set y broken
}
set line [gets $f2]
puts $f1 $line
set backline [gets $f1]
if {"$line" != "$backline"} {
set y broken
}
close $f1
close $f2
set y
} ok
test io-29.14 {Tcl_WriteChars, buffering and implicit flush at close} {
file delete $path(test3)
set f [open $path(test3) w]
puts -nonewline $f "Text1"
puts -nonewline $f " Text 2"
puts $f " Text 3"
close $f
set f [open $path(test3) r]
set x [gets $f]
close $f
set x
} {Text1 Text 2 Text 3}
test io-29.15 {Tcl_Flush, channel not open for writing} {
file delete $path(test1)
set fd [open $path(test1) w]
close $fd
set fd [open $path(test1) r]
set x [list [catch {flush $fd} msg] $msg]
close $fd
string compare $x
[list 1 "channel "$fd" wasn't opened for writing"]
} 0
test io-29.16 {Tcl_Flush on pipe opened only for reading} {stdio openpipe} {
set fd [open "|[list [interpreter] cat longfile]" r]
set x [list [catch {flush $fd} msg] $msg]
catch {close $fd}
string compare $x
[list 1 "channel "$fd" wasn't opened for writing"]
} 0
test io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 hello
puts $f1 hello
puts $f1 hello
flush $f1
set x [file size $path(test1)]
close $f1
set x
} 18
test io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} {
file delete $path(test1)
set x ""
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 hello
puts $f1 hello
puts $f1 hello
flush $f1
lappend x [file size $path(test1)]
puts $f1 hello
flush $f1
lappend x [file size $path(test1)]
puts $f1 hello
flush $f1
lappend x [file size $path(test1)]
close $f1
set x
} {18 24 30}
test io-29.19 {Explicit and implicit flushes} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
set x ""
puts $f1 hello
puts $f1 hello
puts $f1 hello
flush $f1
lappend x [file size $path(test1)]
puts $f1 hello
flush $f1
lappend x [file size $path(test1)]
puts $f1 hello
close $f1
lappend x [file size $path(test1)]
set x
} {18 24 30}
test io-29.20 {Implicit flush when buffer is full} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
for {set x 0} {$x < 100} {incr x} {
puts $f1 $line
}
set z ""
lappend z [file size $path(test1)]
for {set x 0} {$x < 100} {incr x} {
puts $f1 $line
}
lappend z [file size $path(test1)]
close $f1
lappend z [file size $path(test1)]
set z
} {4096 12288 12600}
test io-29.21 {Tcl_Flush to pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {set x [read stdin 6]}
puts $f1 {set cnt [string length $x]}
puts $f1 {puts "read $cnt characters"}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x [gets $f1]
catch {close $f1}
set x
} "read 6 characters"
test io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
fconfigure stdout -buffering full
puts hello
puts hello
flush stdout
gets stdin
puts bye
flush stdout
}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
set x ""
lappend x [gets $f1]
lappend x [gets $f1]
puts $f1 hello
flush $f1
lappend x [gets $f1]
close $f1
set x
} {hello hello bye}
test io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
puts hello
puts hello
gets stdin
puts bye
}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
set x ""
lappend x [gets $f1]
lappend x [gets $f1]
puts $f1 hello
flush $f1
lappend x [gets $f1]
close $f1
set x
} {hello hello bye}
test io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} {
set f [open $path(test3) w]
puts $f "Line 1"
puts $f "Line 2"
set f2 [open $path(test3)]
set x {}
lappend x [read -nonewline $f2]
close $f2
flush $f
set f2 [open $path(test3)]
lappend x [read -nonewline $f2]
close $f2
close $f
set x
} "{} {Line 1nLine 2}"
test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpipe fileevent} {
file delete $path(test3)
set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w]
puts $f "Line 1"
puts $f "Line 2"
close $f
after 100
set f [open $path(test3) r]
set x [read $f]
close $f
set x
} "Line 1nLine 2n"
test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs openpipe} {
set f [open "|[list cat -u]" r+]
puts $f "Line1"
flush $f
set x [gets $f]
close $f
set x
} {Line1}
test io-29.27 {Tcl_Flush on closed pipeline} {stdio openpipe} {
file delete $path(pipe)
set f [open $path(pipe) w]
puts $f {exit}
close $f
set f [open "|[list [interpreter] $path(pipe)]" r+]
gets $f
puts $f output
after 50
#
# The flush below will get a SIGPIPE. This is an expected part of
# test and indicates that the test operates correctly. If you run
# this test under a debugger, the signal will by intercepted unless
# you disable the debugger's signal interception.
#
if {[catch {flush $f} msg]} {
set x [list 1 $msg $errorCode]
catch {close $f}
} else {
if {[catch {close $f} msg]} {
set x [list 1 $msg $errorCode]
} else {
set x {this was supposed to fail and did not}
}
}
regsub {".*":} $x {"":} x
string tolower $x
} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}}
test io-29.28 {Tcl_WriteChars, lf mode} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
puts $f hellontherenandnhere
flush $f
set s [file size $path(test1)]
close $f
set s
} 21
test io-29.29 {Tcl_WriteChars, cr mode} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
puts $f hellontherenandnhere
close $f
file size $path(test1)
} 21
test io-29.30 {Tcl_WriteChars, crlf mode} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
puts $f hellontherenandnhere
close $f
file size $path(test1)
} 25
test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} {
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f "set f [[list open $path(output) w]]"
puts $f {fconfigure $f -translation lf}
set x [list while {![eof stdin]}]
set x "$x {"
puts $f $x
puts $f { puts -nonewline $f [read stdin 4096]}
puts $f { flush $f}
puts $f "}"
puts $f {close $f}
close $f
set x 01234567890123456789012345678901
for {set i 0} {$i < 11} {incr i} {
set x "$x$x"
}
set f [open $path(output) w]
close $f
set f [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
set counter 0
while {([file size $path(output)] < 65536) && ($counter < 1000)} {
incr counter
after 5
update
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
} ok
test io-29.32 {Tcl_WriteChars, background flush to slow reader}
{stdio asyncPipeClose openpipe} {
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f "set f [[list open $path(output) w]]"
puts $f {fconfigure $f -translation lf}
set x [list while {![eof stdin]}]
set x "$x {"
puts $f $x
puts $f { after 20}
puts $f { puts -nonewline $f [read stdin 1024]}
puts $f { flush $f}
puts $f "}"
puts $f {close $f}
close $f
set x 01234567890123456789012345678901
for {set i 0} {$i < 11} {incr i} {
set x "$x$x"
}
set f [open $path(output) w]
close $f
set f [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
set counter 0
while {([file size $path(output)] < 65536) && ($counter < 1000)} {
incr counter
after 20
update
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
} ok
test io-29.33 {Tcl_Flush, implicit flush on exit} {exec} {
set f [open $path(script) w]
puts $f "set f [[list open $path(test1) w]]"
puts $f {fconfigure $f -translation lf
puts $f hello
puts $f bye
puts $f strange
}
close $f
exec [interpreter] $path(script)
set f [open $path(test1) r]
set r [read $f]
close $f
set r
} "hellonbyenstrangen"
test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac fileevent} {
variable c 0
variable x running
set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
proc writelots {s l} {
for {set i 0} {$i < 2000} {incr i} {
puts $s $l
}
}
proc accept {s a p} {
variable x
fileevent $s readable [namespace code [list readit $s]]
fconfigure $s -blocking off
set x accepted
}
proc readit {s} {
variable c
variable x
set l [gets $s]
if {[eof $s]} {
close $s
set x done
} elseif {([string length $l] > 0) || ![fblocked $s]} {
incr c
}
}
set ss [socket -server [namespace code accept] 0]
set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
vwait [namespace which -variable x]
fconfigure $cs -blocking off
writelots $cs $l
close $cs
close $ss
vwait [namespace which -variable x]
set c
} 2000
test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac fileevent} {
# On Mac, this test screws up sockets such that subsequent tests using port 2828
# either cause errors or panic().
catch {interp delete x}
catch {interp delete y}
interp create x
interp create y
set s [socket -server [namespace code accept] 0]
proc accept {s a p} {
puts $s hello
close $s
}
set c [socket [info hostname] [lindex [fconfigure $s -sockname] 2]]
interp share {} $c x
interp share {} $c y
close $c
x eval {
proc readit {s} {
gets $s
if {[eof $s]} {
close $s
}
}
}
y eval {
proc readit {s} {
gets $s
if {[eof $s]} {
close $s
}
}
}
x eval "fileevent $c readable {readit $c}"
y eval "fileevent $c readable {readit $c}"
y eval [list close $c]
update
close $s
interp delete x
interp delete y
} ""
# Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read.
test io-30.1 {Tcl_Write lf, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set x [read $f]
close $f
set x
} "hellontherenandnheren"
test io-30.2 {Tcl_Write lf, Tcl_Read cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set x [read $f]
close $f
set x
} "hellontherenandnheren"
test io-30.3 {Tcl_Write lf, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "hellontherenandnheren"
test io-30.4 {Tcl_Write cr, Tcl_Read cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set x [read $f]
close $f
set x
} "hellontherenandnheren"
test io-30.5 {Tcl_Write cr, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set x [read $f]
close $f
set x
} "hellorthererandrherer"
test io-30.6 {Tcl_Write cr, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "hellorthererandrherer"
test io-30.7 {Tcl_Write crlf, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "hellontherenandnheren"
test io-30.8 {Tcl_Write crlf, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set x [read $f]
close $f
set x
} "hellorntherernandrnherern"
test io-30.9 {Tcl_Write crlf, Tcl_Read cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set x [read $f]
close $f
set x
} "hellonntherennandnnherenn"
test io-30.10 {Tcl_Write lf, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
set c [read $f]
set x [fconfigure $f -translation]
close $f
list $c $x
} {{hello
there
and
here
} auto}
test io-30.11 {Tcl_Write cr, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
set c [read $f]
set x [fconfigure $f -translation]
close $f
list $c $x
} {{hello
there
and
here
} auto}
test io-30.12 {Tcl_Write crlf, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
set c [read $f]
set x [fconfigure $f -translation]
close $f
list $c $x
} {{hello
there
and
here
} auto}
test io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
puts -nonewline $f x ;# shift crlf across block boundary
for {set i 0} {$i < 700} {incr i} {
puts $f $line
}
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto
set c [read $f]
close $f
string length $c
} [expr 700*15+1]
test io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
puts -nonewline $f x ;# shift crlf across block boundary
for {set i 0} {$i < 700} {incr i} {
puts $f $line
}
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set c [read $f]
close $f
string length $c
} [expr 700*15+1]
test io-30.15 {Tcl_Write mixed, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hellontherenandrhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto
set c [read $f]
close $f
set c
} {hello
there
and
here
}
test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f hellontherenandrherenx1a
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar x1a -translation auto
set c [read $f]
close $f
set c
} {hello
there
and
here
}
test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {pcOnly} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -eofchar x1a -translation lf
puts $f hellontherenandrhere
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar x1a -translation auto
set c [read $f]
close $f
set c
} {hello
there
and
here
}
test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abcndefn%cghinqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar x1a -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1 {} 1}
test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abcndefn%cghinqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar x1a -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1 {} 1}
test io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set s [format "abcndefn%cghinqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar {}
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} "abc def 0 x1aghi 0 qrs 0 {} 1"
test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set s [format "abcndefn%cghinqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar {}
set l ""
set x [gets $f]
lappend l [string compare $x "abcndefnx1aghinqrsn"]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {0 1 {} 1}
test io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set s [format "abcndefn%cghinqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar {}
set l ""
set x [gets $f]
lappend l [string compare $x "abcndefnx1aghinqrsn"]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {0 1 {} 1}
test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format abcndefn%cqrsntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar x1a
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format abcndefn%cqrsntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar x1a
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format abcndefn%cqrsntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar x1a
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format abcndefn%cqrsntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar x1a
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format abcndefn%cqrsntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar x1a
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format abcndefn%cqrsntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar x1a
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
# Test end of line translations. Functions tested are Tcl_Write and Tcl_Gets.
test io-31.1 {Tcl_Write lf, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
close $f
set l
} {hello 6 auto there 12 auto}
test io-31.2 {Tcl_Write cr, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
close $f
set l
} {hello 6 auto there 12 auto}
test io-31.3 {Tcl_Write crlf, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
close $f
set l
} {hello 7 auto there 14 auto}
test io-31.4 {Tcl_Write lf, Tcl_Gets lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
close $f
set l
} {hello 6 lf there 12 lf}
test io-31.5 {Tcl_Write lf, Tcl_Gets cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set l ""
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {21 21 cr 1 {} 21 cr 1}
test io-31.6 {Tcl_Write lf, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set l ""
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {21 21 crlf 1 {} 21 crlf 1}
test io-31.7 {Tcl_Write cr, Tcl_Gets cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {hello 6 cr 0 there 12 cr 0}
test io-31.8 {Tcl_Write cr, Tcl_Gets lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set l ""
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {21 21 lf 1 {} 21 lf 1}
test io-31.9 {Tcl_Write cr, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set l ""
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {21 21 crlf 1 {} 21 crlf 1}
test io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {hello 7 crlf 0 there 14 crlf 0}
test io-31.11 {Tcl_Write crlf, Tcl_Gets cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {hello 6 cr 0 6 13 cr 0}
test io-31.12 {Tcl_Write crlf, Tcl_Gets lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hellontherenandnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set l ""
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {6 7 lf 0 6 14 lf 0}
test io-31.13 {binary mode is synonym of lf mode} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation binary
set x [fconfigure $f -translation]
close $f
set x
} lf
#
# Test io-9.14 has been removed because "auto" output translation mode is
# not supoprted.
#
test io-31.14 {Tcl_Write mixed, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hellonthererandrnhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.15 {Tcl_Write mixed, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f hellonthererandrnherer
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.16 {Tcl_Write mixed, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f hellonthererandrnheren
close $f
set f [open $path(test1) r]
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.17 {Tcl_Write mixed, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f hellonthererandrnherern
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "hellontherenandrheren%c" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar x1a -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -eofchar x1a -translation lf
puts $f hellontherenandrhere
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar x1a -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf