# Copyright © 1991-1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
}
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
variable umaskValue
variable path
variable f
variable i
variable n
variable v
variable msg
variable expected
catch {
::tcltest::loadTestedCommands
package require -exact tcl::test [info patchlevel]
set ::tcltestlib [info loaded {} Tcltest]
}
source [file join [file dirname [info script]] tcltests.tcl]
testConstraint pointerIs64bit [expr {$::tcl_platform(pointerSize) >= 8}]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testchannel [llength [info commands testchannel]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
testConstraint testobj [llength [info commands testobj]]
testConstraint testservicemode [llength [info commands testservicemode]]
# Some things fail under Windows in Continuous Integration systems for subtle
# reasons such as CI often running with elevated privileges in a container.
testConstraint notWinCI [expr {
$::tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}]
testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}]
# File permissions broken on wsl without some "exotic" wsl configuration
testConstraint notWsl [expr {[llength [array names ::env *WSL*]] == 0}]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
set umaskValue 0
testConstraint umask [expr {![catch {set umaskValue [scan [exec /bin/sh -c umask] %o]}]}]
testConstraint makeFileInHome [expr {![file exists ~/_test_] && [file writable ~]}]
# 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 -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 -translation binary -blocking 0 -eofchar \x1A
fconfigure stdout -translation binary -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 -translation binary
puts -nonewline $f "a\x4D\x00"
close $f
contents $path(test1)
} "a\x4D\x00"
test io-1.7 {Tcl_WriteChars: WriteChars} {
set f [open $path(test1) w]
fconfigure $f -encoding shiftjis
puts -nonewline $f "a乍\x00"
close $f
contents $path(test1)
} "a\x93\xE1\x00"
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\$O\x1B(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}
proc testreadwrite {size {mode ""} args} {
set tmpfile [file join [temporaryDirectory] io-1.10.tmp]
set w [string repeat A $size]
try {
set fd [open $tmpfile w$mode]
try {
if {[llength $args]} {
fconfigure $fd {*}$args
}
puts -nonewline $fd $w
} finally {
close $fd
}
set fd [open $tmpfile r$mode]
try {
if {[llength $args]} {
fconfigure $fd {*}$args
}
set r [read $fd]
} finally {
close $fd
}
} finally {
file delete $tmpfile
}
string equal $w $r
}
test io-1.10 {WriteChars: large file (> INT_MAX). Bug 3d01d51bc4} -constraints {
pointerIs64bit perf
} -body {
testreadwrite 0x80000000
} -result 1
test io-1.11 {WriteChars: large file (> UINT_MAX). Bug 3d01d51bc4} -constraints {
pointerIs64bit perf
} -body {
testreadwrite 0x100000000 "" -buffersize 1000000
} -result 1
test io-1.12 {WriteChars: large file (== UINT_MAX). Bug 90ff9b7f73} -constraints {
pointerIs64bit perf
} -body {
# *Exactly* UINT_MAX - separate bug from the general large file tests
testreadwrite 0xffffffff
} -result 1
test io-2.1 {WriteBytes} {
# loop until all bytes are written
set f [open $path(test1) w]
fconfigure $f -translation binary -buffersize 16 -translation crlf
puts $f "abcdefghijklmnopqrstuvwxyz"
close $f
contents $path(test1)
} "abcdefghijklmnopqrstuvwxyz\r\n"
test io-2.2 {WriteBytes: savedLF > 0} {
# After flushing buffer, there was a \n left over from the last
# \n -> \r\n expansion. It gets stuck at beginning of this buffer.
set f [open $path(test1) w]
fconfigure $f -translation binary -buffersize 16 -translation crlf
puts -nonewline $f "123456789012345\n12"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "123456789012345\r" "123456789012345\r\n12"]
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 -translation binary -buffering line -translation crlf
puts -nonewline $f "\n12"
set x [contents $path(test1)]
close $f
set x
} "\r\n12"
test io-2.4 {WriteBytes: reset sawLF after each buffer} {
set f [open $path(test1) w]
fconfigure $f -translation binary -buffering line -buffersize 16
puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]
test io-2.5 {WriteBytes: large file (> INT_MAX). Bug 3d01d51bc4} -constraints {
pointerIs64bit perf
} -body {
# Binary mode
testreadwrite 0x80000000 b
} -result 1
test io-2.6 {WriteBytes: large file (> UINT_MAX). Bug 3d01d51bc4} -constraints {
pointerIs64bit perf
} -body {
# Binary mode
testreadwrite 0x100000000 b -buffersize 1000000
} -result 1
test io-2.7 {WriteBytes: large file (== UINT_MAX). Bug 90ff9b7f73} -constraints {
pointerIs64bit perf
} -body {
# *Exactly* UINT_MAX - separate bug from the general large file tests
testreadwrite 0xffffffff b
} -result 1
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)
} "abcdefghijklmnopqrstuvwxyz\r\n"
test io-3.2 {WriteChars: compatibility with WriteBytes: savedLF > 0} {
# After flushing buffer, there was a \n left over from the last
# \n -> \r\n 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 "123456789012345\n12"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "123456789012345\r" "123456789012345\r\n12"]
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
} "\r\n12"
test io-3.4 {WriteChars: loop over stage buffer} -body {
# stage buffer maps to more than can be queued at once.
set f [open $path(test1) w]
fconfigure $f -encoding jis0208 -buffersize 16 -profile tcl8
puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} -cleanup {
catch {close $f}
} -result [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.5 {WriteChars: saved != 0} -body {
# 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 -profile tcl8
puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} -cleanup {
catch {close $f}
} -result [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 Ａ 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 Ａ plus the all of Ｂ) appended.
set f [open $path(test1) w]
fconfigure $f -encoding shiftjis -buffersize 16
puts -nonewline $f "12345678901234ＡＢ"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"]
test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -body {
# 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 -profile tcl8
puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} -cleanup {
catch {close $f}
} -result [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 "abcdefg\nhijklmnopqrstuvwxyz"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]
test io-3.9 {Write: flush line-buffered channels when crlf is split over two buffers} -body {
# https://core.tcl-lang.org/tcllib/tktedit?name=c9d8a52fe
set f [open $path(test1) w]
fconfigure $f -buffering line -translation crlf -buffersize 8
puts $f "1234567"
string map {"\r" "<cr>" "\n" "<lf>"} [contents $path(test1)]
} -cleanup {
close $f
} -result "1234567<cr><lf>"
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 "abcde\n" "abcde\n"]
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 "abcde\r" "abcde\r"]
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 "abcde\r\n" "abcde\r\n"]
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 "1234567\n\n\n\n\nA"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "1234567\r\n\r\n\r\n\r\n\r" "1234567\r\n\r\n\r\n\r\n\r\nA"]
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 "12345678901\n456789012345678901234"
close $f
set x [contents $path(test1)]
} "12345678901\r\n456789012345678901234"
test io-5.1 {CheckFlush: not full} {
set f [open $path(test1) w]
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 "1234567890\n1234567890"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "1234567890\n1234567890" "1234567890\n1234567890"]
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 "foo\nboo"
close $f
set f [open $path(test1)]
set x [gets $f]
close $f
set x
} {foo}
test io-6.2 {Tcl_GetsObj: CheckChannelErrors() != 0} emptyTest {
# 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 "abc\ndefg"
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 "\x81\x34\x00"
close $f
set f [open $path(test1)]
fconfigure $f -translation binary
set x [list [gets $f line] $line]
close $f
set x
} [list 3 "\x81\x34\x00"]
test io-6.5 {Tcl_GetsObj: encoding != NULL} {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts $f "\x88\xEA\x92\x9A"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis
set x [list [gets $f line] $line]
close $f
set x
} [list 2 "一丁"]
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 {
# if (FilterInputBytes(chanPtr, &gs) != 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
puts -nonewline $f "hi\nwould"
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 "abcdef\x1Aghijk\nwombat"
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 "abcdefghijk\nwom\x1Abat"
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 "a\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
} {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 "abcd\nefgh\rijkl\r\nmnop"
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 "efgh\rijkl\r" 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 "a\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
} {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 "abcd\nefgh\rijkl\r\nmnop"
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 "abcd\nefgh" 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: \r\r} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\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 2 "\r\r" -1 ""]
test io-6.26 {Tcl_GetsObj: crlf mode: \r\n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\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 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 "a\r\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
} {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 "abcd\nefgh\rijkl\r\nmnop"
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 "abcd\nefgh\rijkl" 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 "123456789012345\r\nabcdefghijklmnoprstuvwxyz"
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 fileevent} {
# (FilterInputBytes() != 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {crlf lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r"
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 "123456789012345\r\n123"
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 "123456789012345\r"
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 "123456789012345\r" 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 "123456789012345\rabcd\r\nefg"
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 "123456789012345\rabcd" 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: \r\r} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\r"
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: \r\n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\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.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 "a\r\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
} {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 "abcd\nefgh\rijkl\r\nmnop"
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 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 "bbbbbbbbbbbbbbb\n123456789abcdef\r"
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 "\nabcd\refg\x1A"
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 fileevent} {
# not (*eol == '\n')
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
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 "abcd\refg\x1A"
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 fileevent} {
# Tcl_ExternalToUtf()
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
fconfigure $f -encoding utf-16
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
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 "\nabcd\refg"
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 fileevent} {
# memmove()
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
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 "\n\x1A"
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 "123456789012345\r\nabcdefghijklmnopq"
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 "123456789012345\r"
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 "123456\r\n78901"
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 "123456\r78901"
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 "123456\n78901"
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 "123456\x1Ak9012345\r"
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 "there一ok\n丁more bytes\nhere"
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 "there一ok" 11 "丁more bytes" 4 "here"]
test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio 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 "baz\n"
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 "1234567890123０１２３４\nend"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis -buffersize 16
set x [gets $f]
close $f
set x
} "1234567890123０１２３４"
test io-7.2 {FilterInputBytes: split up character in middle of buffer} {
# (bufPtr->nextAdded < bufPtr->bufLength)
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f "1234567890\n123\x82\x4F\x82\x50\x82"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis -profile tcl8
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 -translation binary
puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis -profile tcl8
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 16 "1234567890123０１\x82" 18 0 1 -1 ""]
test io-7.4 {FilterInputBytes: recover from split up character} {stdio fileevent} {
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation binary -buffering none
puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82"
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 -translation binary -blocking 1
puts $f "\x51\x82\x52"
fconfigure $f -encoding shiftjis
vwait [namespace which -variable x]
close $f
set x
} [list -1 "" 1 17 "1234567890123０１２３" 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 "123456789012345\r\n2345678"
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 fileevent} {
# not (bufPtr->nextPtr == NULL)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation lf -encoding ascii -buffering none
puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz"
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 utf-16 -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 fileevent} {
# (bytesLeft == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary}
puts -nonewline $f "abcdefghijklmno\r"
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}\r\nabcdef"
close $f
set f [open $path(test1)]
fconfigure $f -translation 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 fileevent} {
# (bufPtr->nextAdded < bufPtr->length)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary}
puts -nonewline $f "abcdefghijklmno\r"
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 fileevent} {
# ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary} -buffersize 16
puts -nonewline $f "abcdefghijklmno\r"
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 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 "abcdefghijklmno\r"
# 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} emptyTest {
} {}
test io-10.1 {Tcl_ReadChars: CheckChannelErrors} emptyTest {
# 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 -translation 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 -translation 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 -translation 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 -translation binary -eofchar m
# 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 fileevent} {
# (srcRead == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation binary -buffering none -buffersize 16
puts -nonewline $f "123456789012345\x96"
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 -translation 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 "本" 0]
test io-12.5 {ReadChars: fileevents on partial characters} {stdio fileevent} {
set path(test1) [makeFile {
fconfigure stdout -translation 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 牦 {} eof 0 {}"
test io-12.6 {ReadChars: too many chars read} {
proc driver {cmd args} {
variable buffer
variable index
set chan [lindex $args 0]
switch -- $cmd {
initialize {
set index($chan) 0
set buffer($chan) [encoding convertto utf-8 \
[string repeat 뻯 20][string repeat . 20]]
return {initialize finalize watch read}
}
finalize {
unset index($chan) buffer($chan)
return
}
watch {}
read {
set n [lindex $args 1]
set new [expr {$index($chan) + $n}]
set result [string range $buffer($chan) $index($chan) $new-1]
set index($chan) $new
return $result
}
}
}
set c [chan create read [namespace which driver]]
chan configure $c -encoding utf-8
while {![eof $c]} {
read $c 15
}
close $c
} {}
test io-12.7 {ReadChars: too many chars read [bc5b790099]} {
proc driver {cmd args} {
variable buffer
variable index
set chan [lindex $args 0]
switch -- $cmd {
initialize {
set index($chan) 0
set buffer($chan) [encoding convertto utf-8 \
[string repeat 뻯 10]....뻯]
return {initialize finalize watch read}
}
finalize {
unset index($chan) buffer($chan)
return
}
watch {}
read {
set n [lindex $args 1]
set new [expr {$index($chan) + $n}]
set result [string range $buffer($chan) $index($chan) $new-1]
set index($chan) $new
return $result
}
}
}
set c [chan create read [namespace which driver]]
chan configure $c -encoding utf-8
while {![eof $c]} {
read $c 7
}
close $c
} {}
test io-12.8 {ReadChars: multibyte chars split} {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f [string repeat a 9]\xC2\xA0
close $f
set f [open $path(test1)]
fconfigure $f -encoding utf-8 -buffersize 10
set in [read $f]
close $f
scan [string index $in end] %c
} 160
apply [list {} {
set template {
test {io-12.9 @variant@} {ReadChars: multibyte chars split, default (strict)} -body {
set res {}
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f [string repeat a 9]\xC2
close $f
set f [open $path(test1)]
fconfigure $f -encoding utf-8 @strict@ -buffersize 10
set status [catch {read $f} cres copts]
if {$status} {
if {[dict exists $copts -result read]} {
set in [dict get $copts -result read]
} else {
set in {}
}
} else {
set in $cres
}
lappend res $in
lappend res $status $cres
set scan [scan [string index $in end] %c]
lappend res $scan
set status [catch {read $f} cres copts]
if {$status} {
if {[dict exists $copts -result read]} {
set in [dict get $copts -result read]
} else {
set in {}
}
} else {
set in $cres
}
lappend res $in
lappend res $status $cres
set scan [scan [string index $in end] %c]
lappend res $scan
set res
} -cleanup {
catch {close $f}
} -match glob -result @result@
}
set errorres {aaaaaaaaa 1 {error reading "file*":\
invalid or incomplete multibyte or wide character} 97\
{} 1 {error reading "file*":\
invalid or incomplete multibyte or wide character} {}}
# if default encoding is not currently to strict
# foreach variant {default encodingstrict} strict {{} {-encodingstrict 1}}
foreach variant {
{profile default} {profile strict} {profile tcl8}
} strict {{} {-profile strict} {-profile tcl8}} result [list \
$errorres $errorres [
list aaaaaaaaa\xC2 0 aaaaaaaaa\xC2 194 {} 0 {} {}]
] {
set script [string map [
list @result@ [list $result] @variant@ $variant @strict@ $strict] $template]
uplevel 1 $script
}
} [namespace current]]
test io-13.1 {TranslateInputEOL: cr mode} {} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\rdef\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [read $f]
close $f
set x
} "abcd\ndef\n"
test io-13.2 {TranslateInputEOL: crlf mode} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef\r\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcd\ndef\n"
test io-13.3 {TranslateInputEOL: crlf mode: naked cr} {
# (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcd\ndef\r"
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 "abcd\r\ndef\rfgh"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcd\ndef\rfgh"
test io-13.5 {TranslateInputEOL: crlf mode: naked lf} {
# (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef\nfgh"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcd\ndef\nfgh"
test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel 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 "abcdefghj\r"
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 "abcdefghj\n" 1 "01234" 0]
test io-13.7 {TranslateInputEOL: auto mode: naked \r} testchannel {
# (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [read $f] [testchannel queuedcr $f]]
close $f
set x
} [list "abcd\n" 1]
test io-13.8 {TranslateInputEOL: auto mode: \r\n} {
# (*src == '\n')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [read $f]
close $f
set x
} "abcd\ndef"
test io-13.8.1 {TranslateInputEOL: auto mode: \r\n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x {}
lappend x [read $f 5]
lappend x [read $f]
close $f
set x
} [list "abcd\n" "def"]
test io-13.8.2 {TranslateInputEOL: auto mode: \r\n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto -buffersize 6
set x {}
lappend x [read $f 5]
lappend x [read $f]
close $f
set x
} [list "abcd\n" "def"]
test io-13.8.3 {TranslateInputEOL: auto mode: \r\n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\n\r\ndef"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto -buffersize 7
set x {}
lappend x [read $f 5]
lappend x [read $f]
close $f
set x
} [list "abcd\n" "\ndef"]
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 "abcd\rdef"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [read $f]
close $f
set x
} "abcd\ndef"
test io-13.10 {TranslateInputEOL: auto mode: \n} {
# not (*src == '\r')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\ndef"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [read $f]
close $f
set x
} "abcd\ndef"
test io-13.11 {TranslateInputEOL: EOF char} {
# (*chanPtr->inEofChar != '\x00')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\ndefgh"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto -eofchar e
set x [read $f]
close $f
set x
} "abcd\nd"
test io-13.12 {TranslateInputEOL: find EOF char in src} {
# (*chanPtr->inEofChar != '\x00')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\n\r\n\r\nab\r\n\r\ndef\r\n\r\n\r\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto -eofchar e
set x [read $f]
close $f
set x
} "\n\n\nab\n\nd"
# Test standard handle management. The functions tested are
# Tcl_SetStdChannel and Tcl_GetStdChannel. Incidentally we are
# also testing channel table management.
if {[info commands testchannel] != ""} {
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 {
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 stdout is used before stderr
test io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec} {
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
stdout
} {stderr
}}
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 {
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 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} emptyTest {
} {}
test io-16.1 {Tcl_DeleteCloseHandler} emptyTest {
} {}
# 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 -force $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 -force $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} {win} {
set f [open $path(test1) w+]
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
} {{} {auto crlf}}
test io-20.3 {Tcl_CreateChannel: initial settings} {unix} {
set f [open $path(test1) w+]
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
} {{} {auto lf}}
set path(stdout) [makeFile {} stdout]
test io-20.5 {Tcl_CreateChannel: install channel in empty slot} stdio {
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} emptyTest {
} {}
# 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} emptyTest {
# 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
puts $f "1234567890\n098765432"
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 {
# "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
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
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
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} \
{unixOrWin} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -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)]
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 notWinCI} {
# This test may fail on old Unix systems (seen on IRIX64 6.5) with
# obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197.
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
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)} {
after 20 [list incr [namespace which -variable counter]]
vwait [namespace which -variable counter]
}
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} {
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f {
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
puts -nonewline $f $x
close $f
set counter 0
while {([file size $path(output)] < 20480) && ($counter < 1000)} {
after 20 [list incr [namespace which -variable counter]]
vwait [namespace which -variable counter]
}
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 [list {*}$consoleFileNames $f]] \
$consoleFileNames]
string compare $l $x
} 0
test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel} {
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
lsort $l
} {file1 file2}
test io-28.6 {
close channel in write event handler
Should not produce a segmentation fault in a Tcl built with
--enable-symbols and -DPURIFY
} debugpurify {
variable done
variable res
after 0 [list coroutine c1 apply [list {} {
variable done
# just enough of a refchan for the purpose of the test
set chan [chan create w {apply {{cmd chan args} {
switch $cmd {
initialize {
list initialize finalize watch write configure blocking
}
watch {
chan postevent $chan write
}
}
}}}]
chan configure $chan -blocking 0
while 1 {
chan event $chan writable [list [info coroutine]]
yield
close $chan
set done 1
return
}
} [namespace current]]]
vwait [namespace current]::done
return success
} success
test io-28.7 {
close channel in read event handler
Should not produce a segmentation fault in a Tcl built with
--enable-symbols and -DPURIFY
} debugpurify {
variable done
variable res
after 0 [list coroutine c1 apply [list {} {
variable done
set chan [chan create r {apply {{cmd chan args} {
switch $cmd {
blocking - finalize {
}
watch {
chan postevent $chan read
}
initialize {
list initialize finalize watch read write configure blocking
}
default {
error [list {unexpected command} $cmd]
}
}
}}}]
chan configure $chan -blocking 0
while 1 {
chan event $chan readable [list [info coroutine]]
yield
close $chan
set done 1
return
}
} [namespace current]]]
vwait [namespace current]::done
return success
} success
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]
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]
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
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
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
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
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
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]
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 {
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 {
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 {
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
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
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 {
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 {
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 {
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 1\nLine 2}"
test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio 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 1\nLine 2\n"
test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs} {
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 {
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
puts $f hello\nthere\nand\nhere
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
puts $f hello\nthere\nand\nhere
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
puts $f hello\nthere\nand\nhere
close $f
file size $path(test1)
} 25
test io-29.31 {Tcl_WriteChars, background flush} stdio {
# This test may fail on old Unix systems (seen on IRIX64 6.5) with
# obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197.
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)} {
after 10 [list incr [namespace which -variable counter]]
vwait [namespace which -variable counter]
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
# allow a little time for the background process to close.
# otherwise, the following test fails on the [file delete $path(output)]
# on Windows because a process still has the file open.
after 100 set v 1; vwait v
set result
} ok
test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
{stdio asyncPipeClose notWinCI} {
# This test may fail on old Unix systems (seen on IRIX64 6.5) with
# obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197.
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)} {
after 20 [list incr [namespace which -variable counter]]
vwait [namespace which -variable counter]
}
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
} "hello\nbye\nstrange\n"
set path(script2) [makeFile {} script2]
test io-29.33b {TIP#398, no implicit flush of nonblocking on exit} {exec} {
set f [open $path(script) w]
puts $f {
fconfigure stdout -blocking 0
puts -nonewline stdout [string repeat A 655360]
flush stdout
}
close $f
set f [open $path(script2) w]
puts $f {after 2000}
close $f
set t1 [clock milliseconds]
set ff [open "|[list [interpreter] $path(script2)]" w]
catch {unset ::env(TCL_FLUSH_NONBLOCKING_ON_EXIT)}
exec [interpreter] $path(script) >@ $ff
set t2 [clock milliseconds]
close $ff
expr {($t2-$t1)/2000 ? $t2-$t1 : 0}
} 0
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 < 9000} {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] -myaddr 127.0.0.1 0]
set cs [socket 127.0.0.1 [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
} 9000
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] -myaddr 127.0.0.1 0]
proc accept {s a p} {
puts $s hello
close $s
}
set c [socket 127.0.0.1 [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 io-29.36.1 {gets on translation auto with "\r" in QA communication mode, possible regression, bug [b3977d199b]} -constraints {
socket tempNotMac fileevent
} -setup {
set s [open "|[list [interpreter] << {
proc accept {so args} {
fconfigure $so -translation binary
puts -nonewline $so "who are you?\r"; flush $so
set a [gets $so]
puts -nonewline $so "really $a?\r"; flush $so
set a [gets $so]
close $so
set ::done $a
}
set s [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
puts [lindex [fconfigure $s -sockname] 2]
foreach c {1 2} {
vwait ::done
puts $::done
}
}]" r]
set c {}
set result {}
} -body {
set port [gets $s]
foreach t {{cr lf} {auto lf}} {
set c [socket 127.0.0.1 $port]
fconfigure $c -buffering line -translation $t
lappend result $t
while {1} {
set q [gets $c]
switch -- $q {
"who are you?" {puts $c "client"}
"really client?" {puts $c "yes"; lappend result $q; break}
default {puts $c "wrong"; lappend result "unexpected input \"$q\""; break}
}
}
lappend result [gets $s]
close $c; set c {}
}
set result
} -cleanup {
close $s
if {$c ne {}} { close $c }
unset -nocomplain s c port t q
} -result [list {cr lf} "really client?" yes {auto lf} "really client?" yes]
test io-29.36.2 {gets on translation auto with "\r\n" in different buffers, bug [b3977d199b]} -constraints {
socket tempNotMac fileevent
} -setup {
set s [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
set c {}
} -body {
set ::cnt 0
proc accept {so args} {
fconfigure $so -translation binary
puts -nonewline $so "1 line\r"
puts -nonewline $so "\n2 li"
flush $so
# now force separate packets
puts -nonewline $so "ne\r"
flush $so
if {$::cnt & 1} {
vwait ::cli; # simulate short delay (so client can process events, just wait for it)
} else {
# we don't have a delay, so client would get the lines as single chunk
}
# we'll try with "\r" and without "\r" (to cover both branches, where "\r" and "eof" causes exit from [gets] by 3rd line)
puts -nonewline $so "\n3 line"
if {!($::cnt % 3)} {
puts -nonewline $so "\r"
}
flush $so
close $so
}
while {$::cnt < 6} { incr ::cnt
set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
fconfigure $c -blocking 0 -buffering line -translation auto
fileevent $c readable [list apply {c {
if {[gets $c line] >= 0} {
lappend ::cli <$line>
} elseif {[eof $c]} {
set ::done 1
}
}} $c]
vwait ::done
close $c; set c {}
}
set ::cli
} -cleanup {
close $s
if {$c ne {}} { close $c }
unset -nocomplain ::done ::cli ::cnt s c
} -result [lrepeat 6 {<1 line>} {<2 line>} {<3 line>}]
# 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 hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set x [read $f]
close $f
set x
} "hello\nthere\nand\nhere\n"
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 hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set x [read $f]
close $f
set x
} "hello\nthere\nand\nhere\n"
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 hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "hello\nthere\nand\nhere\n"
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 hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set x [read $f]
close $f
set x
} "hello\nthere\nand\nhere\n"
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 hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set x [read $f]
close $f
set x
} "hello\rthere\rand\rhere\r"
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 hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "hello\rthere\rand\rhere\r"
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 hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "hello\nthere\nand\nhere\n"
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 hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set x [read $f]
close $f
set x
} "hello\r\nthere\r\nand\r\nhere\r\n"
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 hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set x [read $f]
close $f
set x
} "hello\n\nthere\n\nand\n\nhere\n\n"
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 hello\nthere\nand\nhere
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 hello\nthere\nand\nhere
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 hello\nthere\nand\nhere
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 hello\nthere\nand\rhere
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 hello\nthere\nand\rhere\n\x1A
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
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} {win} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar \x1A
puts $f hello\nthere\nand\rhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
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 "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
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 "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
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
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
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
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set l ""
set x [gets $f]
lappend l [string compare $x "abc\ndef\n\x1Aghi\nqrs\n"]
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
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set l ""
set x [gets $f]
lappend l [string compare $x "abc\ndef\n\x1Aghi\nqrs\n"]
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 abc\ndef\n%cqrs\ntuv 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 abc\ndef\n%cqrs\ntuv 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 abc\ndef\n%cqrs\ntuv 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 abc\ndef\n%cqrs\ntuv 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 abc\ndef\n%cqrs\ntuv 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 abc\ndef\n%cqrs\ntuv 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 hello\nthere\nand\nhere
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 hello\nthere\nand\nhere
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 hello\nthere\nand\nhere
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 hello\nthere\nand\nhere
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 hello\nthere\nand\nhere
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 hello\nthere\nand\nhere
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 hello\nthere\nand\nhere
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 hello\nthere\nand\nhere
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 hello\nthere\nand\nhere
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 hello\nthere\nand\nhere
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 hello\nthere\nand\nhere
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 hello\nthere\nand\nhere
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 supported.
#
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 hello\nthere\rand\r\nhere
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 hello\nthere\rand\r\nhere\r
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 hello\nthere\rand\r\nhere\n
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 hello\nthere\rand\r\nhere\r\n
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 "hello\nthere\nand\rhere\n\%c" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
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 -translation lf -eofchar \x1A
puts $f hello\nthere\nand\rhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
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
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set l ""
lappend l [gets $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}
test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set l ""
lappend l [gets $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}
test io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
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 \x1Aqrs 0 tuv 0 {} 1"
test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
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 \x1Aqrs 0 tuv 0 {} 1"
test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
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 \x1Aqrs 0 tuv 0 {} 1"
test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set l ""
lappend l [gets $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}
test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1A
set l ""
lappend l [gets $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}
test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set l ""
lappend l [gets $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}
test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1A
set l ""
lappend l [gets $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}
test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set l ""
lappend l [gets $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}
test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1A
set l ""
lappend l [gets $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}
test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets 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 ""
while {[gets $f line] >= 0} {
append c $line\n
}
close $f
string length $c
} [expr {700*15+1}]
test io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets 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 ""
while {[gets $f line] >= 0} {
append c $line\n
}
close $f
string length $c
} [expr {700*15+1}]
# Test Tcl_Read and buffering.
test io-32.1 {Tcl_Read, channel not readable} {
list [catch {read stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test io-32.2 {Tcl_Read, zero byte count} {
read stdin 0
} ""
test io-32.3 {Tcl_Read, negative byte count} {
set f [open $path(longfile) r]
set l [list [catch {read $f -1} msg] $msg]
close $f
set l
} {1 {expected non-negative integer but got "-1"}}
test io-32.4 {Tcl_Read, positive byte count} {
set f [open $path(longfile) r]
set x [read $f 1024]
set s [string length $x]
unset x
close $f
set s
} 1024
test io-32.5 {Tcl_Read, multiple buffers} {
set f [open $path(longfile) r]
fconfigure $f -buffersize 100
set x [read $f 1024]
set s [string length $x]
unset x
close $f
set s
} 1024
test io-32.6 {Tcl_Read, very large read} {
set f1 [open $path(longfile) r]
set z [read $f1 1000000]
close $f1
set l [string length $z]
set x ok
set z [file size $path(longfile)]
if {$z != $l} {
set x broken
}
set x
} ok
test io-32.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
set f1 [open $path(longfile) r]
fconfigure $f1 -blocking off
set z [read $f1 20]
close $f1
set l [string length $z]
set x ok
if {$l != 20} {
set x broken
}
set x
} ok
test io-32.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
set f1 [open $path(longfile) r]
fconfigure $f1 -blocking off
set z [read $f1 1000000]
close $f1
set x ok
set l [string length $z]
set z [file size $path(longfile)]
if {$z != $l} {
set x broken
}
set x
} ok
test io-32.9 {Tcl_Read, read to end of file} {
set f1 [open $path(longfile) r]
set z [read $f1]
close $f1
set l [string length $z]
set x ok
set z [file size $path(longfile)]
if {$z != $l} {
set x broken
}
set x
} ok
test io-32.10 {Tcl_Read from a pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x [read $f1]
close $f1
set x
} "hello\n"
test io-32.11 {Tcl_Read from a pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {puts [gets stdin]}
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x ""
lappend x [read $f1 6]
puts $f1 hello
flush $f1
lappend x [read $f1]
close $f1
set x
} {{hello
} {hello
}}
test io-32.11.1 {Tcl_Read from a pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {chan configure stdout -translation crlf}
puts $f1 {puts [gets stdin]}
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x ""
lappend x [read $f1 6]
puts $f1 hello
flush $f1
lappend x [read $f1]
close $f1
set x
} {{hello
} {hello
}}
test io-32.11.2 {Tcl_Read from a pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {chan configure stdout -translation crlf}
puts $f1 {puts [gets stdin]}
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x ""
lappend x [read $f1 6]
puts $f1 hello
flush $f1
lappend x [read $f1]
close $f1
set x
} {{hello
} {hello
}}
test io-32.12 {Tcl_Read, -nonewline} {
file delete $path(test1)
set f1 [open $path(test1) w]
puts $f1 hello
puts $f1 bye
close $f1
set f1 [open $path(test1) r]
set c [read -nonewline $f1]
close $f1
set c
} {hello
bye}
test io-32.13 {Tcl_Read, -nonewline} {
file delete $path(test1)
set f1 [open $path(test1) w]
puts $f1 hello
puts $f1 bye
close $f1
set f1 [open $path(test1) r]
set c [read -nonewline $f1]
close $f1
list [string length $c] $c
} {9 {hello
bye}}
test io-32.14 {Tcl_Read, reading in small chunks} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
set f [open $path(test1)]
set x [list [read $f 1] [read $f 2] [read $f]]
close $f
set x
} {T wo { lines: this one
and this one
}}
test io-32.15 {Tcl_Read, asking for more input than available} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
set f [open $path(test1)]
set x [read $f 100]
close $f
set x
} {Two lines: this one
and this one
}
test io-32.16 {Tcl_Read, read to end of file with -nonewline} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
set f [open $path(test1)]
set x [read -nonewline $f]
close $f
set x
} {Two lines: this one
and this one}
# Test Tcl_Gets.
test io-33.1 {Tcl_Gets, reading what was written} {
file delete $path(test1)
set f1 [open $path(test1) w]
set y "first line"
puts $f1 $y
close $f1
set f1 [open $path(test1) r]
set x [gets $f1]
set z ok
if {"$x" != "$y"} {
set z broken
}
close $f1
set z
} ok
test io-33.2 {Tcl_Gets into variable} {
set f1 [open $path(longfile) r]
set c [gets $f1 x]
set l [string length x]
set z ok
if {$l != $l} {
set z broken
}
close $f1
set z
} ok
test io-33.3 {Tcl_Gets from pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x [gets $f1]
close $f1
set z ok
if {"$x" != "hello"} {
set z broken
}
set z
} ok
test io-33.4 {Tcl_Gets with long line} {
file delete $path(test3)
set f [open $path(test3) w]
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
close $f
set f [open $path(test3)]
set x [gets $f]
close $f
set x
} {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
set f [open $path(test3) w]
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
close $f
test io-33.5 {Tcl_Gets with long line} {
set f [open $path(test3)]
set x [gets $f y]
close $f
list $x $y
} {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
test io-33.6 {Tcl_Gets and end of file} {
file delete $path(test3)
set f [open $path(test3) w]
puts -nonewline $f "Test1\nTest2"
close $f
set f [open $path(test3)]
set x {}
set y {}
lappend x [gets $f y] $y
set y {}
lappend x [gets $f y] $y
set y {}
lappend x [gets $f y] $y
close $f
set x
} {5 Test1 5 Test2 -1 {}}
test io-33.7 {Tcl_Gets and bad variable} {
set f [open $path(test3) w]
puts $f "Line 1"
puts $f "Line 2"
close $f
catch {unset x}
set x 24
set f [open $path(test3) r]
set result [list [catch {gets $f x(0)} msg] $msg]
close $f
set result
} {1 {can't set "x(0)": variable isn't array}}
test io-33.8 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
fconfigure $f -translation lf
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 100} {incr y} {puts $f $x}
close $f
set f [open $path(test3) r]
fconfigure $f -translation lf
for {set y 0} {$y < 100} {incr y} {gets $f}
close $f
set y
} 100
test io-33.9 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
fconfigure $f -translation lf
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 200} {incr y} {puts $f $x}
close $f
set f [open $path(test3) r]
fconfigure $f -translation lf
for {set y 0} {$y < 200} {incr y} {gets $f}
close $f
set y
} 200
test io-33.10 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
fconfigure $f -translation lf
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 300} {incr y} {puts $f $x}
close $f
set f [open $path(test3) r]
fconfigure $f -translation lf
for {set y 0} {$y < 300} {incr y} {gets $f}
close $f
set y
} 300
test io-33.11 {TclGetsObjBinary, [10dc6daa37]} -setup {
proc driver {cmd args} {
variable buffer
variable index
set chan [lindex $args 0]
switch -- $cmd {
initialize {
set index($chan) 0
set buffer($chan) .......
return {initialize finalize watch read}
}
finalize {
unset index($chan) buffer($chan)
return
}
watch {}
read {
set n [lindex $args 1]
if {$n > 3} {set n 3}
set new [expr {$index($chan) + $n}]
set result [string range $buffer($chan) $index($chan) $new-1]
set index($chan) $new
return $result
}
}
}
} -body {
set c [chan create read [namespace which driver]]
chan configure $c -translation binary -blocking 0
list [gets $c] [gets $c] [gets $c] [gets $c]
} -cleanup {
close $c
rename driver {}
} -result {{} {} {} .......}
test io-33.12 {Tcl_GetsObj, [10dc6daa37]} -setup {
proc driver {cmd args} {
variable buffer
variable index
set chan [lindex $args 0]
switch -- $cmd {
initialize {
set index($chan) 0
set buffer($chan) .......
return {initialize finalize watch read}
}
finalize {
unset index($chan) buffer($chan)
return
}
watch {}
read {
set n [lindex $args 1]
if {$n > 3} {set n 3}
set new [expr {$index($chan) + $n}]
set result [string range $buffer($chan) $index($chan) $new-1]
set index($chan) $new
return $result
}
}
}
} -body {
set c [chan create read [namespace which driver]]
chan configure $c -blocking 0
list [gets $c] [gets $c] [gets $c] [gets $c]
} -cleanup {
close $c
rename driver {}
} -result {{} {} {} .......}
test io-33.13 {Tcl_GetsObj, [10dc6daa37]} -setup {
proc driver {cmd args} {
variable buffer
variable index
set chan [lindex $args 0]
switch -- $cmd {
initialize {
set index($chan) 0
set buffer($chan) [string repeat \
[string repeat . 64]\n[string repeat . 25] 2]
return {initialize finalize watch read}
}
finalize {
unset index($chan) buffer($chan)
return
}
watch {}
read {
set n [lindex $args 1]
if {$n > 65} {set n 65}
set new [expr {$index($chan) + $n}]
set result [string range $buffer($chan) $index($chan) $new-1]
set index($chan) $new
return $result
}
}
}
} -body {
set c [chan create read [namespace which driver]]
chan configure $c -blocking 0
list [gets $c] [gets $c] [gets $c] [gets $c] [gets $c]
} -cleanup {
close $c
rename driver {}
} -result [list [string repeat . 64] {} [string repeat . 89] \
[string repeat . 25] {}]
# Test Tcl_Seek and Tcl_Tell.
test io-34.1 {Tcl_Seek to current position at start of file} {
set f1 [open $path(longfile) r]
seek $f1 0 current
set c [tell $f1]
close $f1
set c
} 0
test io-34.2 {Tcl_Seek to offset from start} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 10 start
set c [tell $f1]
close $f1
set c
} 10
test io-34.3 {Tcl_Seek to end of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 0 end
set c [tell $f1]
close $f1
set c
} 54
test io-34.4 {Tcl_Seek to offset from end of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 -10 end
set c [tell $f1]
close $f1
set c
} 44
test io-34.5 {Tcl_Seek to offset from current position} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 10 current
seek $f1 10 current
set c [tell $f1]
close $f1
set c
} 20
test io-34.6 {Tcl_Seek to offset from end of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 -10 end
set c [tell $f1]
set r [read $f1]
close $f1
list $c $r
} {44 {rstuvwxyz
}}
test io-34.7 {Tcl_Seek to offset from end of file, then to current position} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 -10 end
set c1 [tell $f1]
set r1 [read $f1 5]
seek $f1 0 current
set c2 [tell $f1]
close $f1
list $c1 $r1 $c2
} {44 rstuv 49}
test io-34.8 {Tcl_Seek on pipes: not supported} stdio {
set f1 [open "|[list [interpreter]]" r+]
set x [list [catch {seek $f1 0 current} msg] $msg]
close $f1
regsub {".*":} $x {"":} x
string tolower $x
} {1 {error during seek on "": invalid argument}}
test io-34.9 {Tcl_Seek, testing buffered input flushing} {
file delete $path(test3)
set f [open $path(test3) w]
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
close $f
set f [open $path(test3) RDWR]
set x [read $f 1]
seek $f 3
lappend x [read $f 1]
seek $f 0 start
lappend x [read $f 1]
seek $f 10 current
lappend x [read $f 1]
seek $f -2 end
lappend x [read $f 1]
seek $f 50 end
lappend x [read $f 1]
seek $f 1
lappend x [read $f 1]
close $f
set x
} {a d a l Y {} b}
set path(test3) [makeFile {} test3]
test io-34.10 {Tcl_Seek testing flushing of buffered input} {
set f [open $path(test3) w]
fconfigure $f -translation lf
puts $f xyz\n123
close $f
set f [open $path(test3) r+]
fconfigure $f -translation lf
set x [gets $f]
seek $f 0 current
puts $f 456
close $f
list $x [viewFile test3]
} "xyz {xyz
456}"
test io-34.11 {Tcl_Seek testing flushing of buffered output} {
set f [open $path(test3) w]
puts $f xyz\n123
close $f
set f [open $path(test3) w+]
puts $f xyzzy
seek $f 2
set x [gets $f]
close $f
list $x [viewFile test3]
} "zzy xyzzy"
test io-34.12 {Tcl_Seek testing combination of write, seek back and read} {
set f [open $path(test3) w]
fconfigure $f -translation lf
puts $f xyz\n123
close $f
set f [open $path(test3) a+]
fconfigure $f -translation lf
puts $f xyzzy
flush $f
set x [tell $f]
seek $f -4 cur
set y [gets $f]
close $f
list $x [viewFile test3] $y
} {14 {xyz
123
xyzzy} zzy}
test io-34.13 {Tcl_Tell at start of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
set p [tell $f1]
close $f1
set p
} 0
test io-34.14 {Tcl_Tell after seek to end of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 0 end
set c1 [tell $f1]
close $f1
set c1
} 54
test io-34.15 {Tcl_Tell combined with seeking} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 10 start
set c1 [tell $f1]
seek $f1 10 current
set c2 [tell $f1]
close $f1
list $c1 $c2
} {10 20}
test io-34.16 {Tcl_Tell on pipe: always -1} stdio {
set f1 [open "|[list [interpreter]]" r+]
set c [tell $f1]
close $f1
set c
} -1
test io-34.17 {Tcl_Tell on pipe: always -1} stdio {
set f1 [open "|[list [interpreter]]" r+]
puts $f1 {puts hello}
flush $f1
set c [tell $f1]
gets $f1
close $f1
set c
} -1
test io-34.18 {Tcl_Tell combined with seeking and reading} {
file delete $path(test2)
set f [open $path(test2) w]
fconfigure $f -translation lf
puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n"
close $f
set f [open $path(test2)]
fconfigure $f -translation lf
set x [tell $f]
read $f 3
lappend x [tell $f]
seek $f 2
lappend x [tell $f]
seek $f 10 current
lappend x [tell $f]
seek $f 0 end
lappend x [tell $f]
close $f
set x
} {0 3 2 12 30}
test io-34.19 {Tcl_Tell combined with opening in append mode} {
set f [open $path(test3) w]
fconfigure $f -translation lf
puts $f "abcdefghijklmnopqrstuvwxyz"
puts $f "abcdefghijklmnopqrstuvwxyz"
close $f
set f [open $path(test3) a]
set c [tell $f]
close $f
set c
} 54
test io-34.20 {Tcl_Tell combined with writing} {
set f [open $path(test3) w]
set l ""
seek $f 29 start
lappend l [tell $f]
puts -nonewline $f a
seek $f 39 start
lappend l [tell $f]
puts -nonewline $f a
lappend l [tell $f]
seek $f 407 end
lappend l [tell $f]
close $f
set l
} {29 39 40 447}
test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport extensive} {
file delete $path(test3)
set f [open $path(test3) w]
fconfigure $f -translation binary
set l ""
lappend l [tell $f]
puts -nonewline $f abcdef
lappend l [tell $f]
flush $f
lappend l [tell $f]
# 4GB offset!
seek $f 0x100000000
lappend l [tell $f]
puts -nonewline $f abcdef
lappend l [tell $f]
close $f
lappend l [file size $path(test3)]
# truncate...
close [open $path(test3) w]
lappend l [file size $path(test3)]
set l
} {0 6 6 4294967296 4294967302 4294967302 0}
# Test Tcl_Eof
test io-35.1 {Tcl_Eof} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f hello
puts $f hello
close $f
set f [open $path(test1)]
set x [eof $f]
lappend x [eof $f]
gets $f
lappend x [eof $f]
gets $f
lappend x [eof $f]
gets $f
lappend x [eof $f]
lappend x [eof $f]
close $f
set x
} {0 0 0 0 1 1}
test io-35.2 {Tcl_Eof with pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {gets stdin}
puts $f1 {puts hello}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
set x [eof $f1]
flush $f1
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
close $f1
set x
} {0 0 0 1}
test io-35.3 {Tcl_Eof with pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {gets stdin}
puts $f1 {puts hello}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
set x [eof $f1]
flush $f1
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
close $f1
set x
} {0 0 0 1 1 1}
test io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} {
file delete $path(test1)
set f [open $path(test1) w]
close $f
set f [open $path(test1) r]
fconfigure $f -blocking off
set l ""
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {{} 1}
test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} stdio {
file delete $path(pipe)
set f [open $path(pipe) w]
puts $f {
exit
}
close $f
set f [open "|[list [interpreter] $path(pipe)]" r]
set l ""
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {{} 1}
test io-35.6 {Tcl_Eof, eof char, lf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar \x1A
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {8 8 1}
test io-35.7 {Tcl_Eof, eof char, lf write, lf read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar \x1A
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1A
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {8 8 1}
test io-35.8 {Tcl_Eof, eof char, cr write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar \x1A
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {8 8 1}
test io-35.9 {Tcl_Eof, eof char, cr write, cr read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar \x1A
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1A
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {8 8 1}
test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar \x1A
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {10 8 1}
test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar \x1A
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1A
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {10 8 1}
test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {17 8 1}
test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1A
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {17 8 1}
test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {17 8 1}
test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1A
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {17 8 1}
test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {21 8 1}
test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1A
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {21 8 1}
test io-35.18 {Tcl_Eof, eof char, cr write, crlf read} -body {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation crlf
set l [string length [set in [read $f]]]
set e [eof $f]
close $f
list $s $l $e [scan [string index $in end] %c]
} -result {8 8 1 13}
test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar \x1A
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1A
set l [string length [set in [read $f]]]
set e [eof $f]
close $f
list $s $l $e [scan [string index $in end] %c]
} -result {8 8 1 13}
test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} -body {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar \x1A
puts $f {}
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1A
set l [string length [set in [read $f]]]
set e [eof $f]
close $f
list $s $l $e [scan [string index $in end] %c]
} -result {1 1 1 13}
test io-35.18c {Tcl_Eof, eof char, cr write, crlf read} -body {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f {}
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation crlf
set l [string length [set in [read $f]]]
set e [eof $f]
close $f
list $s $l $e [scan [string index $in end] %c]
} -result {1 1 1 13}
test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} -body {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1A
set l [string length [set in [read $f]]]
set e [eof $f]
close $f
list $c $l $e [scan [string index $in end] %c]
} -result {17 8 1 13}
test io-35.20 {Tcl_Eof, eof char in middle, cr write, crlf read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set i [format \n%cqrsuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1A
set l [string length [set in [read $f]]]
set e [eof $f]
close $f
list $c $l $e [scan [string index $in end] %c]
} {9 1 1 13}
# Test Tcl_InputBlocked
test io-36.1 {Tcl_InputBlocked on nonblocking pipe} stdio {
set f1 [open "|[list [interpreter]]" r+]
puts $f1 {puts hello_from_pipe}
flush $f1
gets $f1
fconfigure $f1 -blocking off -buffering full
puts $f1 {puts hello}
set x ""
lappend x [gets $f1]
lappend x [fblocked $f1]
flush $f1
after 200
lappend x [gets $f1]
lappend x [fblocked $f1]
lappend x [gets $f1]
lappend x [fblocked $f1]
close $f1
set x
} {{} 1 hello 0 {} 1}
test io-36.1.1 {Tcl_InputBlocked on nonblocking binary pipe} stdio {
set f1 [open "|[list [interpreter]]" r+]
chan configure $f1 -translation binary
puts $f1 {
chan configure stdout -translation binary
puts hello_from_pipe
}
flush $f1
gets $f1
fconfigure $f1 -blocking off -buffering full
puts $f1 {puts hello}
set x ""
lappend x [gets $f1]
lappend x [fblocked $f1]
flush $f1
after 200
lappend x [gets $f1]
lappend x [fblocked $f1]
lappend x [gets $f1]
lappend x [fblocked $f1]
close $f1
set x
} {{} 1 hello 0 {} 1}
test io-36.2 {Tcl_InputBlocked on blocking pipe} stdio {
set f1 [open "|[list [interpreter]]" r+]
fconfigure $f1 -buffering line
puts $f1 {puts hello_from_pipe}
set x ""
lappend x [gets $f1]
lappend x [fblocked $f1]
puts $f1 {exit}
lappend x [gets $f1]
lappend x [fblocked $f1]
lappend x [eof $f1]
close $f1
set x
} {hello_from_pipe 0 {} 0 1}
test io-36.3 {Tcl_InputBlocked vs files, short read} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
set f [open $path(test1) r]
set l ""
lappend l [fblocked $f]
lappend l [read $f 3]
lappend l [fblocked $f]
lappend l [read -nonewline $f]
lappend l [fblocked $f]
lappend l [eof $f]
close $f
set l
} {0 abc 0 defghijklmnop 0 1}
test io-36.4 {Tcl_InputBlocked vs files, event driven read} {fileevent} {
proc in {f} {
variable l
variable x
lappend l [read $f 3]
if {[eof $f]} {lappend l eof; close $f; set x done}
}
file delete $path(test1)
set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
set f [open $path(test1) r]
set l ""
fileevent $f readable [namespace code [list in $f]]
variable x
vwait [namespace which -variable x]
set l
} {abc def ghi jkl mno {p
} eof}
test io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
set f [open $path(test1) r]
fconfigure $f -blocking off
set l ""
lappend l [fblocked $f]
lappend l [read $f 3]
lappend l [fblocked $f]
lappend l [read -nonewline $f]
lappend l [fblocked $f]
lappend l [eof $f]
close $f
set l
} {0 abc 0 defghijklmnop 0 1}
test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles fileevent} {
proc in {f} {
variable l
variable x
lappend l [read $f 3]
if {[eof $f]} {lappend l eof; close $f; set x done}
}
file delete $path(test1)
set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
set f [open $path(test1) r]
fconfigure $f -blocking off
set l ""
fileevent $f readable [namespace code [list in $f]]
variable x
vwait [namespace which -variable x]
set l
} {abc def ghi jkl mno {p
} eof}
# Test Tcl_InputBuffered
test io-37.1 {Tcl_InputBuffered} {testchannel} {
set f [open $path(longfile) r]
fconfigure $f -buffersize 4096
read $f 3
set l ""
lappend l [testchannel inputbuffered $f]
lappend l [tell $f]
close $f
set l
} {4093 3}
test io-37.2 {Tcl_InputBuffered, test input flushing on seek} {testchannel} {
set f [open $path(longfile) r]
fconfigure $f -buffersize 4096
read $f 3
set l ""
lappend l [testchannel inputbuffered $f]
lappend l [tell $f]
seek $f 0 current
lappend l [testchannel inputbuffered $f]
lappend l [tell $f]
close $f
set l
} {4093 3 0 3}
# Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize
test io-38.1 {Tcl_GetChannelBufferSize, default buffer size} {
set f [open $path(longfile) r]
set s [fconfigure $f -buffersize]
close $f
set s
} 4096
test io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} {
set f [open $path(longfile) r]
set l ""
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 10000
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 1
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize -1
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 0
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 100000
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 10000000
lappend l [fconfigure $f -buffersize]
close $f
set l
} {4096 10000 1 1 1 100000 1048576}
test io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} {
# This test crashes the interp if Bug #427196 is not fixed
set chan [open [info script] r]
fconfigure $chan -buffersize 10 -encoding utf-8
set var [read $chan 2]
fconfigure $chan -buffersize 32
append var [read $chan]
close $chan
} {}
# Test Tcl_SetChannelOption, Tcl_GetChannelOption
test io-39.1 {Tcl_GetChannelOption} {
file delete $path(test1)
set f1 [open $path(test1) w]
set x [fconfigure $f1 -blocking]
close $f1
set x
} 1
test io-39.2 {Tcl_GetChannelOption} {
file delete $path(test1)
set f1 [open $path(test1) w]
set x [fconfigure $f1 -buffering]
close $f1
set x
} full
test io-39.3 {Tcl_GetChannelOption} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -buffering line
set x [fconfigure $f1 -buffering]
close $f1
set x
} line
test io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} {
file delete $path(test1)
set f1 [open $path(test1) w]
set l ""
lappend l [fconfigure $f1 -buffering]
fconfigure $f1 -buffering line
lappend l [fconfigure $f1 -buffering]
fconfigure $f1 -buffering none
lappend l [fconfigure $f1 -buffering]
fconfigure $f1 -buffering line
lappend l [fconfigure $f1 -buffering]
fconfigure $f1 -buffering full
lappend l [fconfigure $f1 -buffering]
close $f1
set l
} {full line none line full}
test io-39.5 {Tcl_GetChannelOption, invariance} {
file delete $path(test1)
set f1 [open $path(test1) w]
set l ""
lappend l [fconfigure $f1 -buffering]
lappend l [list [catch {fconfigure $f1 -buffering green} msg] $msg]
lappend l [fconfigure $f1 -buffering]
close $f1
set l
} {full {1 {bad value for -buffering: must be one of full, line, or none}} full}
test io-39.6 {Tcl_SetChannelOption, multiple options} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -buffering line
puts $f1 hello
puts $f1 bye
set x [file size $path(test1)]
close $f1
set x
} 10
test io-39.7 {Tcl_SetChannelOption, buffering, translation} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 hello
puts $f1 bye
set x ""
fconfigure $f1 -buffering line
lappend x [file size $path(test1)]
puts $f1 really_bye
lappend x [file size $path(test1)]
close $f1
set x
} {0 21}
test io-39.8 {Tcl_SetChannelOption, different buffering options} {
file delete $path(test1)
set f1 [open $path(test1) w]
set l ""
fconfigure $f1 -translation lf -buffering none
puts -nonewline $f1 hello
lappend l [file size $path(test1)]
puts -nonewline $f1 hello
lappend l [file size $path(test1)]
fconfigure $f1 -buffering full
puts -nonewline $f1 hello
lappend l [file size $path(test1)]
fconfigure $f1 -buffering none
lappend l [file size $path(test1)]
puts -nonewline $f1 hello
lappend l [file size $path(test1)]
close $f1
lappend l [file size $path(test1)]
set l
} {5 10 10 10 20 20}
test io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} {
file delete $path(test1)
set f1 [open $path(test1) w]
close $f1
set f1 [open $path(test1) r]
set x ""
lappend x [fconfigure $f1 -blocking]
fconfigure $f1 -blocking off
lappend x [fconfigure $f1 -blocking]
lappend x [gets $f1]
lappend x [read $f1 1000]
lappend x [fblocked $f1]
lappend x [eof $f1]
close $f1
set x
} {1 0 {} {} 0 1}
test io-39.10 {Tcl_SetChannelOption, blocking mode} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
gets stdin
after 100
puts hi
gets stdin
}
close $f1
set x ""
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f1 -blocking off -buffering line
lappend x [fconfigure $f1 -blocking]
lappend x [gets $f1]
lappend x [fblocked $f1]
fconfigure $f1 -blocking on
puts $f1 hello
fconfigure $f1 -blocking off
lappend x [gets $f1]
lappend x [fblocked $f1]
fconfigure $f1 -blocking on
puts $f1 bye
fconfigure $f1 -blocking off
lappend x [gets $f1]
lappend x [fblocked $f1]
fconfigure $f1 -blocking on
lappend x [fconfigure $f1 -blocking]
lappend x [gets $f1]
lappend x [fblocked $f1]
lappend x [eof $f1]
lappend x [gets $f1]
lappend x [eof $f1]
close $f1
set x
} {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1}
test io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size clipped to lower bound} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -buffersize -10
set x [fconfigure $f -buffersize]
close $f
set x
} 1
test io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size clipped to upper bound} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -buffersize 10000000
set x [fconfigure $f -buffersize]
close $f
set x
} 1048576
test io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -buffersize 40000
set x [fconfigure $f -buffersize]
close $f
set x
} 40000
test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f \xE7\x89\xA6
close $f
set f [open $path(test1) r]
fconfigure $f -encoding utf-8
set x [read $f]
close $f
set x
} 牦
test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f \xE7\x89\xA6
close $f
set f [open $path(test1) r]
fconfigure $f -encoding utf-8
set x [read $f]
close $f
set x
} 牦
test io-39.16 {Tcl_SetChannelOption: -encoding (shortened to "-en"), errors} -body {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -en foobar
} -cleanup {
close $f
} -returnCodes 1 -result {unknown encoding "foobar"}
test io-39.16a {Tcl_SetChannelOption: -encoding (invalid shortening to "-e"), errors} -body {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -e foobar
} -cleanup {
close $f
} -returnCodes 1 -match glob -result {bad option "-e": should be one of *}
test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio fileevent} {
set f [open "|[list [interpreter] $path(cat)]" r+]
fconfigure $f -encoding iso8859-1
puts -nonewline $f "\xE7"
flush $f
fconfigure $f -encoding utf-8 -blocking 0
variable x {}
fileevent $f readable [namespace code { lappend x [read $f] }]
vwait [namespace which -variable x]
after 300 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
fconfigure $f -encoding utf-8
vwait [namespace which -variable x]
after 300 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
fconfigure $f -translation binary
vwait [namespace which -variable x]
after 300 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
close $f
set x
} "{} timeout {} timeout \xE7 timeout"
test io-39.18 {Tcl_SetChannelOption, setting read mode independently} \
{socket} {
proc accept {s a p} {close $s}
set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $s1 -sockname] 2]
set s2 [socket 127.0.0.1 $port]
update
fconfigure $s2 -translation {auto lf}
set modes [fconfigure $s2 -translation]
close $s1
close $s2
set modes
} {auto lf}
test io-39.19 {Tcl_SetChannelOption, setting read mode independently} \
{socket} {
proc accept {s a p} {close $s}
set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $s1 -sockname] 2]
set s2 [socket 127.0.0.1 $port]
update
fconfigure $s2 -translation {auto crlf}
set modes [fconfigure $s2 -translation]
close $s1
close $s2
set modes
} {auto crlf}
test io-39.20 {Tcl_SetChannelOption, setting read mode independently} \
{socket} {
proc accept {s a p} {close $s}
set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $s1 -sockname] 2]
set s2 [socket 127.0.0.1 $port]
update
fconfigure $s2 -translation {auto cr}
set modes [fconfigure $s2 -translation]
close $s1
close $s2
set modes
} {auto cr}
test io-39.21 {Tcl_SetChannelOption, setting read mode independently} \
{socket} {
proc accept {s a p} {close $s}
set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $s1 -sockname] 2]
set s2 [socket 127.0.0.1 $port]
update
fconfigure $s2 -translation {auto auto}
set modes [fconfigure $s2 -translation]
close $s1
close $s2
set modes
} {auto crlf}
test io-39.22 {Tcl_SetChannelOption, invariance} -constraints unix -body {
file delete $path(test1)
set f1 [open $path(test1) w+]
set l ""
lappend l [fconfigure $f1 -eofchar]
fconfigure $f1 -eofchar {O {}}
lappend l [fconfigure $f1 -eofchar]
fconfigure $f1 -eofchar D
lappend l [fconfigure $f1 -eofchar]
close $f1
set l
} -result {{} O D}
test io-39.22a {Tcl_SetChannelOption, invariance} -body {
file delete $path(test1)
set f1 [open $path(test1) w+]
set l [list]
fconfigure $f1 -eofchar {O {}}
lappend l [fconfigure $f1 -eofchar]
fconfigure $f1 -eofchar D
lappend l [fconfigure $f1 -eofchar]
lappend l [list [catch {fconfigure $f1 -eofchar {1 2 3}} msg] $msg]
close $f1
set l
} -result {O D {1 {bad value for -eofchar: must be non-NUL ASCII character}}}
test io-39.23 {Tcl_GetChannelOption, server socket is not readable or
writable, it should still have valid -eofchar and -translation options } {
set l [list]
set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
close $sock
set l
} {{} auto}
test io-39.24 {Tcl_SetChannelOption, server socket is not readable or
writable so we can't change -eofchar or -translation } {
set l [list]
set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
fconfigure $sock -eofchar D -translation lf
lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
close $sock
set l
} {{} auto}
test io-40.1 {POSIX open access modes: RDWR} {
file delete $path(test3)
set f [open $path(test3) w]
puts $f xyzzy
close $f
set f [open $path(test3) RDWR]
puts -nonewline $f "ab"
seek $f 0 current
set x [gets $f]
close $f
set f [open $path(test3) r]
lappend x [gets $f]
close $f
set x
} {zzy abzzy}
test io-40.2 {POSIX open access modes: CREAT} {unix notWsl} {
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT} 0o600]
file stat $path(test3) stats
set x [format "%#o" [expr {$stats(mode)&0o777}]]
puts $f "line 1"
close $f
set f [open $path(test3) r]
lappend x [gets $f]
close $f
set x
} {0o600 {line 1}}
test io-40.3 {POSIX open access modes: CREAT} {unix umask notWsl} {
# This test only works if your umask is 2, like ouster's.
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT}]
close $f
file stat $path(test3) stats
format 0o%03o [expr {$stats(mode)&0o777}]
} [format 0o%03o [expr {0o666 & ~ $umaskValue}]]
test io-40.4 {POSIX open access modes: CREAT} {
file delete $path(test3)
set f [open $path(test3) w]
puts $f xyzzy
close $f
set f [open $path(test3) {WRONLY CREAT}]
puts -nonewline $f "ab"
close $f
set f [open $path(test3) r]
set x [gets $f]
close $f
set x
} abzzy
test io-40.5 {POSIX open access modes: APPEND} {
file delete $path(test3)
set f [open $path(test3) w]
fconfigure $f -translation lf
puts $f xyzzy
close $f
set f [open $path(test3) {WRONLY APPEND}]
fconfigure $f -translation lf
puts $f "new line"
seek $f 0
puts $f "abc"
close $f
set f [open $path(test3) r]
fconfigure $f -translation lf
set x ""
seek $f 6 current
lappend x [gets $f]
lappend x [gets $f]
close $f
set x
} {{new line} abc}
test io-40.6 {POSIX open access modes: EXCL} -match regexp -body {
file delete $path(test3)
set f [open $path(test3) w]
puts $f xyzzy
close $f
open $path(test3) {WRONLY CREAT EXCL}
} -returnCodes error -result {(?i)couldn't open ".*test3": file (already )?exists}
test io-40.7 {POSIX open access modes: EXCL} {
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT EXCL}]
puts $f "A test line"
close $f
viewFile test3
} {A test line}
test io-40.8 {POSIX open access modes: TRUNC} {
file delete $path(test3)
set f [open $path(test3) w]
puts $f xyzzy
close $f
set f [open $path(test3) {WRONLY TRUNC}]
puts $f abc
close $f
set f [open $path(test3) r]
set x [gets $f]
close $f
set x
} abc
test io-40.9 {POSIX open access modes: NONBLOCK} {nonPortable unix} {
file delete $path(test3)
set f [open $path(test3) {WRONLY NONBLOCK CREAT}]
puts $f "NONBLOCK test"
close $f
set f [open $path(test3) r]
set x [gets $f]
close $f
set x
} {NONBLOCK test}
test io-40.10 {POSIX open access modes: RDONLY} {
set f [open $path(test1) w]
puts $f "two lines: this one"
puts $f "and this"
close $f
set f [open $path(test1) RDONLY]
set x [list [gets $f] [catch {puts $f Test} msg] $msg]
close $f
string compare [string tolower $x] \
[list {two lines: this one} 1 \
[format "channel \"%s\" wasn't opened for writing" $f]]
} 0
test io-40.11 {POSIX open access modes: RDONLY} -match regexp -body {
file delete $path(test3)
open $path(test3) RDONLY
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test io-40.12 {POSIX open access modes: WRONLY} -match regexp -body {
file delete $path(test3)
open $path(test3) WRONLY
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test io-40.13 {POSIX open access modes: WRONLY} {
makeFile xyzzy test3
set f [open $path(test3) WRONLY]
puts -nonewline $f "ab"
seek $f 0 current
set x [list [catch {gets $f} msg] $msg]
close $f
lappend x [viewFile test3]
string compare [string tolower $x] \
[list 1 "channel \"$f\" wasn't opened for reading" abzzy]
} 0
test io-40.14 {POSIX open access modes: RDWR} -match regexp -body {
file delete $path(test3)
open $path(test3) RDWR
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test io-40.15 {POSIX open access modes: RDWR} {
makeFile xyzzy test3
set f [open $path(test3) RDWR]
puts -nonewline $f "ab"
seek $f 0 current
set x [gets $f]
close $f
lappend x [viewFile test3]
} {zzy abzzy}
test io-40.16 {tilde substitution in open} -constraints makeFileInHome -setup {
makeFile {Some text} _test_ ~
} -body {
file exists [file join $::env(HOME) _test_]
} -cleanup {
removeFile _test_ ~
} -result 1
test io-40.17 {tilde substitution in open} {
set home $::env(HOME)
unset ::env(HOME)
set x [list [catch {open ~/foo} msg] $msg]
set ::env(HOME) $home
set x
} {1 {couldn't open "~/foo": no such file or directory}}
test io-41.1 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent foo} msg] $msg
} {1 {wrong # args: should be "fileevent channel event ?script?"}}
test io-41.2 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent foo bar baz q} msg] $msg
} {1 {wrong # args: should be "fileevent channel event ?script?"}}
test io-41.3 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent gorp readable} msg] $msg
} {1 {can not find channel named "gorp"}}
test io-41.4 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent gorp writable} msg] $msg
} {1 {can not find channel named "gorp"}}
test io-41.5 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent gorp who-knows} msg] $msg
} {1 {bad event name "who-knows": must be readable or writable}}
#
# Test fileevent on a file
#
set path(foo) [makeFile {} foo]
set f [open $path(foo) w+]
test io-42.1 {Tcl_FileeventCmd: creating, deleting, querying} {fileevent} {
list [fileevent $f readable] [fileevent $f writable]
} {{} {}}
test io-42.2 {Tcl_FileeventCmd: replacing} {fileevent} {
set result {}
fileevent $f r "first script"
lappend result [fileevent $f readable]
fileevent $f r "new script"
lappend result [fileevent $f readable]
fileevent $f r "yet another"
lappend result [fileevent $f readable]
fileevent $f r ""
lappend result [fileevent $f readable]
} {{first script} {new script} {yet another} {}}
test io-42.3 {Tcl_FileeventCmd: replacing, with NULL chars in script} {fileevent} {
set result {}
fileevent $f r "first scr\x00ipt"
lappend result [string length [fileevent $f readable]]
fileevent $f r "new scr\x00ipt"
lappend result [string length [fileevent $f readable]]
fileevent $f r "yet ano\x00ther"
lappend result [string length [fileevent $f readable]]
fileevent $f r ""
lappend result [fileevent $f readable]
} {13 11 12 {}}
test io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixExecs fileevent} {
set result {}
fileevent $f readable "script 1"
lappend result [fileevent $f readable] [fileevent $f writable]
fileevent $f writable "write script"
lappend result [fileevent $f readable] [fileevent $f writable]
fileevent $f readable {}
lappend result [fileevent $f readable] [fileevent $f writable]
fileevent $f writable {}
lappend result [fileevent $f readable] [fileevent $f writable]
} {{script 1} {} {script 1} {write script} {} {write script} {} {}}
test io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent} -body {
set result {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f r "read f"
fileevent $f2 r "read f2"
fileevent $f3 r "read f3"
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f2 r {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f3 r {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f r {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {{} {} {} {read f} {read f2} {read f3} {read f} {} {read f3} {read f} {} {} {} {} {}}
test io-44.1 {FileEventProc procedure: normal read event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent} -body {
fileevent $f2 readable [namespace code {
set x [gets $f2]; fileevent $f2 readable {}
}]
puts $f2 text; flush $f2
variable x initial
vwait [namespace which -variable x]
set x
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {text}
test io-44.2 {FileEventProc procedure: error in read event} -constraints {
stdio unixExecs fileevent
} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
proc myHandler {msg options} {
variable x $msg
}
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
} -body {
fileevent $f2 readable {error bogus}
puts $f2 text; flush $f2
variable x initial
vwait [namespace which -variable x]
list $x [fileevent $f2 readable]
} -cleanup {
interp bgerror {} $handler
catch {close $f2}
catch {close $f3}
} -result {bogus {}}
test io-44.3 {FileEventProc procedure: normal write event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent} -body {
fileevent $f2 writable [namespace code {
lappend x "triggered"
incr count -1
if {$count <= 0} {
fileevent $f2 writable {}
}
}]
variable x initial
set count 3
vwait [namespace which -variable x]
vwait [namespace which -variable x]
vwait [namespace which -variable x]
set x
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {initial triggered triggered triggered}
test io-44.4 {FileEventProc procedure: eror in write event} -constraints {
stdio unixExecs fileevent
} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
proc myHandler {msg options} {
variable x $msg
}
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
} -body {
fileevent $f2 writable {error bad-write}
variable x initial
vwait [namespace which -variable x]
list $x [fileevent $f2 writable]
} -cleanup {
interp bgerror {} $handler
catch {close $f2}
catch {close $f3}
} -result {bad-write {}}
test io-44.5 {FileEventProc procedure: end of file} -constraints {
stdio unixExecs fileevent
} -body {
set f4 [open "|[list [interpreter] $path(cat) << foo]" r]
fileevent $f4 readable [namespace code {
if {[gets $f4 line] < 0} {
lappend x eof
fileevent $f4 readable {}
} else {
lappend x $line
}
}]
variable x initial
vwait [namespace which -variable x]
vwait [namespace which -variable x]
set x
} -cleanup {
close $f4
} -result {initial foo eof}
close $f
test io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup {
} -constraints {stdio fileevent openpipe} -body {
namespace eval refchan {
namespace ensemble create
namespace export *
proc finalize {chan args} {
namespace delete c_$chan
}
proc initialize {chan args} {
namespace eval c_$chan {}
namespace upvar c_$chan watching watching
set watching {}
list finalize initialize seek watch write
}
proc watch {chan args} {
namespace upvar c_$chan watching watching
foreach arg $args {
switch $arg {
write {
if {$arg ni $watching} {
lappend watching $arg
}
chan postevent $chan $arg
}
}
}
}
proc write {chan args} {
chan postevent $chan write
return 1
}
}
set f [chan create w [namespace which refchan]]
chan configure $f -blocking 0
set data "some data"
set x 0
chan event $f writable [namespace code {
puts $f $data
incr count [string length $data]
if {$count > 262144} {
chan event $f writable {}
set x done
}
}]
set token [after 10000 [namespace code {
set x timeout
}]]
vwait [namespace which -variable x]
return $x
} -cleanup {
after cancel $token
catch {chan close $f}
} -result done
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} {
set f [open $path(foo) r]
fileevent $f readable [namespace code {
lappend x "binding triggered: \"[gets $f]\""
fileevent $f readable {}
}]
close $f
set x initial
after 100 [namespace code { set y done }]
variable y
vwait [namespace which -variable y]
set x
} {initial}
test io-45.2 {DeleteFileEvent, cleanup on close} {fileevent} {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
fileevent $f readable [namespace code {
lappend x "f triggered: \"[gets $f]\""
fileevent $f readable {}
}]
fileevent $f2 readable [namespace code {
lappend x "f2 triggered: \"[gets $f2]\""
fileevent $f2 readable {}
}]
close $f
variable x initial
vwait [namespace which -variable x]
close $f2
set x
} {initial {f2 triggered: "foo bar"}}
test io-45.3 {DeleteFileEvent, cleanup on close} {fileevent} {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
set f3 [open $path(foo) r]
fileevent $f readable {f script}
fileevent $f2 readable {f2 script}
fileevent $f3 readable {f3 script}
set x {}
close $f2
lappend x [catch {fileevent $f readable} msg] $msg \
[catch {fileevent $f2 readable}] \
[catch {fileevent $f3 readable} msg] $msg
close $f3
lappend x [catch {fileevent $f readable} msg] $msg \
[catch {fileevent $f2 readable}] \
[catch {fileevent $f3 readable}]
close $f
lappend x [catch {fileevent $f readable}] \
[catch {fileevent $f2 readable}] \
[catch {fileevent $f3 readable}]
} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1}
# Execute these tests only if the "testfevent" command is present.
test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent notOSX} {
testfevent create
set script "set f \[[list open $path(foo) r]]\n"
append script {
set x "no event"
fileevent $f readable [namespace code {
set x "f triggered: [gets $f]"
fileevent $f readable {}
}]
}
set timer [after 10 lappend x timeout]
testfevent cmd $script
vwait x
after cancel $timer
testfevent cmd {close $f}
list [testfevent cmd {set x}] [testfevent cmd {info commands after}]
} {{f triggered: foo bar} after}
test io-46.2 {Tcl event loop vs multiple interpreters} testfevent {
testfevent create
testfevent cmd {
variable x 0
after 100 {set x triggered}
vwait [namespace which -variable x]
set x
}
} {triggered}
test io-46.3 {Tcl event loop vs multiple interpreters} testfevent {
testfevent create
testfevent cmd {
set x 0
after 10 {lappend x timer}
after 30
set result $x
update idletasks
lappend result $x
update
lappend result $x
}
} {0 0 {0 timer}}
test io-47.1 {fileevent vs multiple interpreters} {testfevent fileevent} {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
set f3 [open $path(foo) r]
fileevent $f readable {script 1}
testfevent create
testfevent share $f2
testfevent cmd "fileevent $f2 readable {script 2}"
fileevent $f3 readable {sript 3}
set x {}
lappend x [fileevent $f2 readable]
testfevent delete
lappend x [fileevent $f readable] [fileevent $f2 readable] \
[fileevent $f3 readable]
close $f
close $f2
close $f3
set x
} {{} {script 1} {} {sript 3}}
test io-47.2 {deleting fileevent on interpreter delete} {testfevent fileevent} {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
set f3 [open $path(foo) r]
set f4 [open $path(foo) r]
fileevent $f readable {script 1}
testfevent create
testfevent share $f2
testfevent share $f3
testfevent cmd "fileevent $f2 readable {script 2}
fileevent $f3 readable {script 3}"
fileevent $f4 readable {script 4}
testfevent delete
set x [list [fileevent $f readable] [fileevent $f2 readable] \
[fileevent $f3 readable] [fileevent $f4 readable]]
close $f
close $f2
close $f3
close $f4
set x
} {{script 1} {} {} {script 4}}
test io-47.3 {deleting fileevent on interpreter delete} {testfevent fileevent} {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
set f3 [open $path(foo) r]
set f4 [open $path(foo) r]
testfevent create
testfevent share $f3
testfevent share $f4
fileevent $f readable {script 1}
fileevent $f2 readable {script 2}
testfevent cmd "fileevent $f3 readable {script 3}
fileevent $f4 readable {script 4}"
testfevent delete
set x [list [fileevent $f readable] [fileevent $f2 readable] \
[fileevent $f3 readable] [fileevent $f4 readable]]
close $f
close $f2
close $f3
close $f4
set x
} {{script 1} {script 2} {} {}}
test io-47.4 {file events on shared files and multiple interpreters} {testfevent fileevent} {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
testfevent create
testfevent share $f
testfevent cmd "fileevent $f readable {script 1}"
fileevent $f readable {script 2}
fileevent $f2 readable {script 3}
set x [list [fileevent $f2 readable] \
[testfevent cmd "fileevent $f readable"] \
[fileevent $f readable]]
testfevent delete
close $f
close $f2
set x
} {{script 3} {script 1} {script 2}}
test io-47.5 {file events on shared files, deleting file events} {testfevent fileevent} {
set f [open $path(foo) r]
testfevent create
testfevent share $f
testfevent cmd "fileevent $f readable {script 1}"
fileevent $f readable {script 2}
testfevent cmd "fileevent $f readable {}"
set x [list [testfevent cmd "fileevent $f readable"] \
[fileevent $f readable]]
testfevent delete
close $f
set x
} {{} {script 2}}
test io-47.6 {file events on shared files, deleting file events} {testfevent fileevent} {
set f [open $path(foo) r]
testfevent create
testfevent share $f
testfevent cmd "fileevent $f readable {script 1}"
fileevent $f readable {script 2}
fileevent $f readable {}
set x [list [testfevent cmd "fileevent $f readable"] \
[fileevent $f readable]]
testfevent delete
close $f
set x
} {{script 1} {}}
unset path(foo)
removeFile foo
set path(bar) [makeFile {} bar]
test io-48.1 {testing readability conditions} {fileevent} {
set f [open $path(bar) w]
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
close $f
set f [open $path(bar) r]
fileevent $f readable [namespace code [list consume $f]]
proc consume {f} {
variable l
variable x
lappend l called
if {[eof $f]} {
close $f
set x done
} else {
gets $f
}
}
set l ""
variable x not_done
vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
test io-48.2 {testing readability conditions} {nonBlockFiles fileevent} {
set f [open $path(bar) w]
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
close $f
set f [open $path(bar) r]
fileevent $f readable [namespace code [list consume $f]]
fconfigure $f -blocking off
proc consume {f} {
variable x
variable l
lappend l called
if {[eof $f]} {
close $f
set x done
} else {
gets $f
}
}
set l ""
variable x not_done
vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
set path(my_script) [makeFile {} my_script]
test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles fileevent} {
set f [open $path(bar) w]
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
close $f
set f [open $path(my_script) w]
puts $f {
proc copy_slowly {f} {
while {![eof $f]} {
puts [gets $f]
after 200
}
close $f
}
}
close $f
set f [open "|[list [interpreter]]" r+]
fileevent $f readable [namespace code [list consume $f]]
fconfigure $f -buffering line
fconfigure $f -blocking off
proc consume {f} {
variable l
variable x
if {[eof $f]} {
set x done
} else {
gets $f
lappend l [fblocked $f]
gets $f
lappend l [fblocked $f]
}
}
set l ""
variable x not_done
puts $f [list source $path(my_script)]
puts $f "set f \[[list open $path(bar) r]]"
puts $f {copy_slowly $f}
puts $f {exit}
vwait [namespace which -variable x]
close $f
list $x $l
} {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
unset path(bar)
removeFile bar
test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
variable c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable c
variable x
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable x
variable c
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable x
variable c
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable c
variable x
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable x
variable c
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable c
variable x
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable c
variable x
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1A
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable x
variable c
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1A
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable x
variable c
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1A
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable c
variable x
variable l
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1A
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable c
variable x
variable l
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1A
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable c
variable x
variable l
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1A
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-49.1 {testing crlf reading, leftover cr disgorgment} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
set f [open $path(test1) r]
set l ""
lappend l [file size $path(test1)]
fconfigure $f -translation crlf
lappend l [read $f 1]
lappend l [tell $f]
lappend l [read $f 1]
lappend l [tell $f]
lappend l [read $f 1]
lappend l [tell $f]
lappend l [read $f 1]
lappend l [tell $f]
lappend l [read $f 1]
lappend l [tell $f]
lappend l [read $f 1]
lappend l [tell $f]
lappend l [eof $f]
lappend l [read $f 1]
lappend l [eof $f]
close $f
set l
} "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 {
} 7 0 {} 1"
test io-49.2 {testing crlf reading, leftover cr disgorgment} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
set f [open $path(test1) r]
set l ""
lappend l [file size $path(test1)]
fconfigure $f -translation crlf
lappend l [read $f 2]
lappend l [tell $f]
lappend l [read $f 2]
lappend l [tell $f]
lappend l [read $f 2]
lappend l [tell $f]
lappend l [eof $f]
lappend l [read $f 2]
lappend l [tell $f]
lappend l [eof $f]
close $f
set l
} "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1"
test io-49.3 {testing crlf reading, leftover cr disgorgment} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
set f [open $path(test1) r]
set l ""
lappend l [file size $path(test1)]
fconfigure $f -translation crlf
lappend l [read $f 3]
lappend l [tell $f]
lappend l [read $f 3]
lappend l [tell $f]
lappend l [eof $f]
lappend l [read $f 3]
lappend l [tell $f]
lappend l [eof $f]
close $f
set l
} "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1"
test io-49.4 {testing crlf reading, leftover cr disgorgment} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
set f [open $path(test1) r]
set l ""
lappend l [file size $path(test1)]
fconfigure $f -translation crlf
lappend l [read $f 3]
lappend l [tell $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [eof $f]
close $f
set l
} "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1"
test io-49.5 {testing crlf reading, leftover cr disgorgment} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
set f [open $path(test1) r]
set l ""
lappend l [file size $path(test1)]
fconfigure $f -translation crlf
lappend l [set x [gets $f]]
lappend l [tell $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [eof $f]
close $f
set l
} [list 7 a\rb\rc 7 {} 7 1]
test io-50.1 {testing handler deletion} -constraints {testchannelevent testservicemode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
close $f
update
proc delhandler {f} {
variable z
set z called
testchannelevent $f delete 0
}
set z not_called
set timer [after 50 lappend z timeout]
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list delhandler $f]]
testservicemode 1
vwait z
after cancel $timer
set z
} -cleanup {
close $f
} -result called
test io-50.2 {testing handler deletion with multiple handlers} -constraints {testchannelevent testservicemode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
close $f
proc delhandler {f i} {
variable z
lappend z "called delhandler $i"
testchannelevent $f delete 0
}
set z ""
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list delhandler $f 1]]
testchannelevent $f add readable [namespace code [list delhandler $f 0]]
testservicemode 1
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
set z
} -cleanup {
close $f
} -result {{called delhandler 0} {called delhandler 1}}
test io-50.3 {testing handler deletion with multiple handlers} -constraints {testchannelevent testservicemode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
close $f
set z ""
proc notcalled {f i} {
variable z
lappend z "notcalled was called!! $f $i"
}
proc delhandler {f i} {
variable z
testchannelevent $f delete 1
lappend z "delhandler $i called"
testchannelevent $f delete 0
lappend z "delhandler $i deleted myself"
}
set z ""
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list notcalled $f 1]]
testchannelevent $f add readable [namespace code [list delhandler $f 0]]
testservicemode 1
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
set z
} -cleanup {
close $f
} -result {{delhandler 0 called} {delhandler 0 deleted myself}}
test io-50.4 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode} -setup {
file delete $path(test1)
update
} -body {
set f [open $path(test1) w]
close $f
update
proc delrecursive {f} {
variable z
variable u
if {"$u" == "recursive"} {
testchannelevent $f delete 0
lappend z "delrecursive deleting recursive"
} else {
lappend z "delrecursive calling recursive"
set u recursive
update
}
}
variable u toplevel
variable z ""
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list delrecursive $f]]
testservicemode 1
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
set z
} -cleanup {
close $f
} -result {{delrecursive calling recursive} {delrecursive deleting recursive}}
test io-50.5 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode notOSX} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
close $f
proc notcalled {f} {
variable z
lappend z "notcalled was called!! $f"
}
proc del {f} {
variable u
variable z
if {"$u" == "recursive"} {
testchannelevent $f delete 1
lappend z "del deleted notcalled"
testchannelevent $f delete 0
lappend z "del deleted myself"
} else {
set u recursive
lappend z "del calling recursive"
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
lappend z "del after recursive"
}
}
set z ""
set u toplevel
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list notcalled $f]]
testchannelevent $f add readable [namespace code [list del $f]]
testservicemode 1
set timer [after 50 set z timeout]
vwait z
after cancel $timer
set z
} -cleanup {
close $f
} -result [list {del calling recursive} {del deleted notcalled} \
{del deleted myself} {del after recursive}]
test io-50.6 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
close $f
proc first {f} {
variable u
variable z
variable done
if {"$u" == "toplevel"} {
lappend z "first called"
set u first
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
lappend z "first after toplevel"
set done 1
} else {
lappend z "first called not toplevel"
}
}
proc second {f} {
variable u
variable z
if {"$u" == "first"} {
lappend z "second called, first time"
set u second
testchannelevent $f delete 0
} elseif {"$u" == "second"} {
lappend z "second called, second time"
testchannelevent $f delete 0
} else {
lappend z "second called, cannot happen!"
testchannelevent $f removeall
}
}
set z ""
set u toplevel
set done 0
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list second $f]]
testchannelevent $f add readable [namespace code [list first $f]]
testservicemode 1
update
if {!$done} {
set timer2 [after 200 set done 1]
vwait done
after cancel $timer2
}
set z
} -cleanup {
close $f
} -result [list {first called} {first called not toplevel} \
{second called, first time} {second called, second time} \
{first after toplevel}]
test io-51.1 {Test old socket deletion on Macintosh} {socket} {
set x 0
set result ""
proc accept {s a p} {
variable x
variable wait
fconfigure $s -blocking off
puts $s "sock[incr x]"
close $s
set wait done
}
set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $ss -sockname] 2]
variable wait ""
set cs [socket 127.0.0.1 $port]
vwait [namespace which -variable wait]
lappend result [gets $cs]
close $cs
set wait ""
set cs [socket 127.0.0.1 $port]
vwait [namespace which -variable wait]
lappend result [gets $cs]
close $cs
set wait ""
set cs [socket 127.0.0.1 $port]
vwait [namespace which -variable wait]
lappend result [gets $cs]
close $cs
set wait ""
set cs [socket 127.0.0.1 $port]
vwait [namespace which -variable wait]
lappend result [gets $cs]
close $cs
close $ss
set result
} {sock1 sock2 sock3 sock4}
test io-52.1 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fcopy $f1 $f2 -command { # }
catch { fcopy $f1 $f2 } msg
close $f1
close $f2
string compare $msg "channel \"$f1\" is busy"
} {0}
test io-52.2 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
set f3 [open $thisScript]
fcopy $f1 $f2 -command { # }
catch { fcopy $f3 $f2 } msg
close $f1
close $f2
close $f3
string compare $msg "channel \"$f2\" is busy"
} {0}
test io-52.3 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -encoding utf-8 -translation lf -encoding iso8859-1 -blocking 0
fconfigure $f2 -encoding utf-8 -translation cr -encoding iso8859-1 -blocking 0
set s0 [fcopy $f1 $f2]
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.4 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -encoding utf-8 -translation lf -blocking 0
fconfigure $f2 -encoding utf-8 -translation cr -blocking 0
fcopy $f1 $f2 -size 40
set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
# the file size is 41 because "©" is encoded in two bytes
lappend result [file size $path(test1)]
} {0 0 0 41}
test io-52.4.1 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -encoding utf-8 -translation lf -blocking 0 -buffersize 10000000
fconfigure $f2 -encoding utf-8 -translation cr -blocking 0
fcopy $f1 $f2 -size 40
set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
# the file size is 41 because "©" is encoded in two bytes
lappend result [file size $path(test1)]
} {0 0 0 41}
test io-52.5 {TclCopyChannel, all} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0
fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0
fcopy $f1 $f2 -size -1 ;# -1 means 'copy all', same as if no -size specified.
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {"$s1" == "$s2"} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.5a {TclCopyChannel, all, other negative value} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0
fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0
fcopy $f1 $f2 -size -2 ;# < 0 behaves like -1, copy all
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {"$s1" == "$s2"} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0
fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0
fcopy $f1 $f2 -size 3221176172 ;# Wrapped to < 0, behaves like -1, copy all
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {"$s1" == "$s2"} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.6 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0
fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0
set s0 [fcopy $f1 $f2 -size [expr {[file size $thisScript] + 5}]]
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.7 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0
fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0
fcopy $f1 $f2
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
close $f1
close $f2
if {"$s1" == "$s2"} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.8 {TclCopyChannel} {stdio fcopy} {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
fconfigure $f1 -translation lf
puts $f1 "
puts ready
gets stdin
set f1 \[open [list $thisScript] r\]
fconfigure \$f1 -encoding utf-8 -translation lf
puts \[read \$f1 100\]
close \$f1
"
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f1 -translation lf
gets $f1
puts $f1 ready
flush $f1
set f2 [open $path(test1) w]
fconfigure $f2 -encoding utf-8 -translation lf
set s0 [fcopy $f1 $f2 -size 40]
catch {close $f1}
close $f2
# the file size is 41 because "©" is encoded in two bytes
list $s0 [file size $path(test1)]
} {40 41}
# Empty files, to register them with the test facility
set path(kyrillic.txt) [makeFile {} kyrillic.txt]
set path(utf8-fcopy.txt) [makeFile {} utf8-fcopy.txt]
set path(utf8-rp.txt) [makeFile {} utf8-rp.txt]
# Create kyrillic file, use lf translation to avoid os eol issues
set out [open $path(kyrillic.txt) w]
fconfigure $out -encoding koi8-r -translation lf
puts $out "АА"
close $out
test io-52.9 {TclCopyChannel & encodings} {fcopy} {
# Copy kyrillic to UTF-8, using fcopy.
set in [open $path(kyrillic.txt) r]
set out [open $path(utf8-fcopy.txt) w]
fconfigure $in -encoding koi8-r -translation lf
fconfigure $out -encoding utf-8 -translation lf
fcopy $in $out
close $in
close $out
# Do the same again, but differently (read/puts).
set in [open $path(kyrillic.txt) r]
set out [open $path(utf8-rp.txt) w]
fconfigure $in -encoding koi8-r -translation lf
fconfigure $out -encoding utf-8 -translation lf
puts -nonewline $out [read $in]
close $in
close $out
list [file size $path(kyrillic.txt)] \
[file size $path(utf8-fcopy.txt)] \
[file size $path(utf8-rp.txt)]
} {3 5 5}
test io-52.10 {TclCopyChannel & encodings} -constraints fcopy -body {
set in [open $path(kyrillic.txt) r]
set out [open $path(utf8-fcopy.txt) w]
fconfigure $in -encoding koi8-r -translation lf
fconfigure $out -translation binary
fcopy $in $out
file size $path(utf8-fcopy.txt)
} -cleanup {
close $in
close $out
} -returnCodes 1 -match glob -result {error writing "*":\
invalid or incomplete multibyte or wide character}
test io-52.11 {TclCopyChannel & encodings} -setup {
set out [open $path(utf8-fcopy.txt) w]
fconfigure $out -encoding utf-8 -translation lf -profile strict
puts $out АА
close $out
} -constraints {fcopy} -body {
set in [open $path(utf8-fcopy.txt) r]
set out [open $path(kyrillic.txt) w]
fconfigure $in -translation binary
fconfigure $out -encoding koi8-r -translation lf -profile strict
catch {fcopy $in $out} cres copts
return $cres
} -cleanup {
if {$in in [chan names]} {
close $in
}
if {$out in [chan names]} {
close $out
}
catch {unset cres}
} -match glob -result {error writing "*": invalid or incomplete\
multibyte or wide character}
test io-52.12 {coverage of -translation auto} {
file delete $path(test1) $path(test2)
set out [open $path(test1) wb]
chan configure $out -translation lf
puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
close $out
set in [open $path(test1)]
chan configure $in -buffersize 8
set out [open $path(test2) w]
chan configure $out -translation lf
fcopy $in $out
close $in
close $out
file size $path(test2)
} 29
test io-52.13 {coverage of -translation cr} {
file delete $path(test1) $path(test2)
set out [open $path(test1) wb]
chan configure $out -translation lf
puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
close $out
set in [open $path(test1)]
chan configure $in -buffersize 8 -translation cr
set out [open $path(test2) w]
chan configure $out -translation lf
fcopy $in $out
close $in
close $out
file size $path(test2)
} 30
test io-52.14 {coverage of -translation crlf} {
file delete $path(test1) $path(test2)
set out [open $path(test1) wb]
chan configure $out -translation lf
puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
close $out
set in [open $path(test1)]
chan configure $in -buffersize 8 -translation crlf
set out [open $path(test2) w]
chan configure $out -translation lf
fcopy $in $out
close $in
close $out
file size $path(test2)
} 29
test io-52.14.1 {coverage of -translation crlf} {
file delete $path(test1) $path(test2)
set out [open $path(test1) wb]
chan configure $out -translation lf
puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
close $out
set in [open $path(test1)]
chan configure $in -buffersize 8 -translation crlf
set out [open $path(test2) w]
fcopy $in $out -size 2
close $in
close $out
file size $path(test2)
} 2
test io-52.14.2 {coverage of -translation crlf} {
file delete $path(test1) $path(test2)
set out [open $path(test1) wb]
chan configure $out -translation lf
puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
close $out
set in [open $path(test1)]
chan configure $in -translation crlf
set out [open $path(test2) w]
fcopy $in $out -size 9
close $in
close $out
file size $path(test2)
} 9
test io-52.15 {coverage of -translation crlf} {
file delete $path(test1) $path(test2)
set out [open $path(test1) wb]
chan configure $out -translation lf
puts -nonewline $out abcdefg\r
close $out
set in [open $path(test1)]
chan configure $in -buffersize 8 -translation crlf
set out [open $path(test2) w]
fcopy $in $out
close $in
close $out
file size $path(test2)
} 8
test io-52.16 {coverage of eofChar handling} {
file delete $path(test1) $path(test2)
set out [open $path(test1) wb]
chan configure $out -translation lf
puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
close $out
set in [open $path(test1)]
chan configure $in -buffersize 8 -translation lf -eofchar a
set out [open $path(test2) w]
fcopy $in $out
close $in
close $out
file size $path(test2)
} 0
test io-52.17 {coverage of eofChar handling} {
file delete $path(test1) $path(test2)
set out [open $path(test1) wb]
chan configure $out -translation lf
puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
close $out
set in [open $path(test1)]
chan configure $in -buffersize 8 -translation lf -eofchar d
set out [open $path(test2) w]
fcopy $in $out
close $in
close $out
file size $path(test2)
} 3
test io-52.18 {coverage of eofChar handling} {
file delete $path(test1) $path(test2)
set out [open $path(test1) wb]
chan configure $out -translation lf
puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
close $out
set in [open $path(test1)]
chan configure $in -buffersize 8 -translation crlf -eofchar h
set out [open $path(test2) w]
fcopy $in $out
close $in
close $out
file size $path(test2)
} 8
test io-52.19 {coverage of eofChar handling} {
file delete $path(test1) $path(test2)
set out [open $path(test1) wb]
chan configure $out -translation lf
puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
close $out
set in [open $path(test1)]
chan configure $in -buffersize 10 -translation crlf -eofchar h
set out [open $path(test2) w]
fcopy $in $out
close $in
close $out
file size $path(test2)
} 8
test io-52.20 {TclCopyChannel & encodings} -setup {
set out [open $path(utf8-fcopy.txt) w]
fconfigure $out -encoding utf-8 -translation lf
puts $out "Á"
close $out
} -constraints {fcopy} -body {
# binary to encoding => the input has to be
# in utf-8 to make sense to the encoder
set in [open $path(utf8-fcopy.txt) r]
set out [open $path(kyrillic.txt) w]
# Using "-encoding ascii" means reading the "Á" gives an error
fconfigure $in -encoding ascii -profile strict
fconfigure $out -encoding koi8-r -translation lf
fcopy $in $out
} -cleanup {
close $in
close $out
} -returnCodes 1 -match glob -result {error reading "file*": invalid or incomplete multibyte or wide character}
test io-52.20.1 {TclCopyChannel & read encoding error & tell position, bug [a173f9229]} -setup {
set out [open $path(utf8-fcopy.txt) w]
fconfigure $out -encoding utf-8 -translation lf
puts $out "AÁ"
close $out
} -constraints {fcopy knownBug} -body {
# binary to encoding => the input has to be
# in utf-8 to make sense to the encoder
set in [open $path(utf8-fcopy.txt) r]
set out [open $path(kyrillic.txt) w]
# Using "-encoding ascii" means reading the "Á" gives an error
fconfigure $in -encoding ascii -profile strict
fconfigure $out -encoding koi8-r -translation lf
set l {}
# should fail, so 1 is added
lappend l [catch {fcopy $in $out}]
# should be at position 1, after the first correct byte, so 1 is read.
lappend l [tell $in]
# not sure, if flush required, but anyway
flush $out
# should be at position 1, after the first correct byte, so 1 is written.
lappend l [tell $out]
} -cleanup {
close $in
close $out
} -returnCodes 0 -result {1 1 1}
test io-52.20.2 {TclCopyChannel & encoding error on same encoding} -setup {
set out [open $path(utf8-fcopy.txt) w]
fconfigure $out -encoding utf-8 -translation lf
puts $out "AÁ"
close $out
} -constraints {fcopy} -body {
# binary to encoding => the input has to be
# in utf-8 to make sense to the encoder
set in [open $path(utf8-fcopy.txt) r]
set out [open $path(kyrillic.txt) w]
# Using "-encoding ascii" means reading the "Á" gives an error
fconfigure $in -encoding ascii -profile strict
fconfigure $out -encoding ascii -translation lf
fcopy $in $out
} -cleanup {
close $in
close $out
} -returnCodes 1 -match glob -result {error reading "file*": invalid or incomplete multibyte or wide character}
test io-52.21 {TclCopyChannel & encodings} -setup {
set out [open $path(utf8-fcopy.txt) w]
fconfigure $out -encoding utf-8 -translation lf
puts $out "Á"
close $out
} -constraints {fcopy} -body {
# binary to encoding => the input has to be
# in utf-8 to make sense to the encoder
set in [open $path(utf8-fcopy.txt) r]
set out [open $path(kyrillic.txt) w]
# Using "-encoding ascii" means writing the "Á" gives an error
fconfigure $in -encoding utf-8
fconfigure $out -encoding ascii -translation lf -profile strict
fcopy $in $out
} -cleanup {
close $in
close $out
} -returnCodes 1 -match glob -result {error writing "file*": invalid or incomplete multibyte or wide character}
test io-52.22 {TclCopyChannel & encodings} -setup {
set out [open $path(utf8-fcopy.txt) w]
fconfigure $out -encoding utf-8 -translation lf
puts $out "Á"
close $out
} -constraints {fcopy} -body {
# binary to encoding => the input has to be
# in utf-8 to make sense to the encoder
set in [open $path(utf8-fcopy.txt) r]
set out [open $path(kyrillic.txt) w]
# Using "-encoding ascii" means reading the "Á" gives an error
fconfigure $in -encoding ascii -profile strict
fconfigure $out -encoding koi8-r -translation lf
proc ::xxx args {
set ::s0 $args
}
fcopy $in $out -command ::xxx
vwait ::s0
set ::s0
} -cleanup {
close $in
close $out
unset ::s0
} -match glob -result {0 {error reading "file*": invalid or incomplete multibyte or wide character}}
test io-52.22.1 {TclCopyChannel & encodings & tell position} -setup {
set out [open $path(utf8-fcopy.txt) w]
fconfigure $out -encoding utf-8 -translation lf
puts $out "AÁ"
close $out
} -constraints {fcopy} -body {
# binary to encoding => the input has to be
# in utf-8 to make sense to the encoder
set in [open $path(utf8-fcopy.txt) r]
set out [open $path(kyrillic.txt) w]
# Using "-encoding ascii" means reading the "Á" gives an error
fconfigure $in -encoding ascii -profile strict
fconfigure $out -encoding koi8-r -translation lf
proc ::xxx args {
set ::s0 $args
}
fcopy $in $out -command ::xxx
vwait ::s0
list [tell $in] [tell $out] {*}[set ::s0]
} -cleanup {
close $in
close $out
unset ::s0
} -match glob -result {1 1 1 {error reading "file*": invalid or incomplete multibyte or wide character}}
test io-52.23 {TclCopyChannel & encodings} -setup {
set out [open $path(utf8-fcopy.txt) w]
fconfigure $out -encoding utf-8 -translation lf
puts $out "Á"
close $out
} -constraints {fcopy} -body {
# binary to encoding => the input has to be
# in utf-8 to make sense to the encoder
set in [open $path(utf8-fcopy.txt) r]
set out [open $path(kyrillic.txt) w]
# Using "-encoding ascii" means writing the "Á" gives an error
fconfigure $in -encoding utf-8
fconfigure $out -encoding ascii -translation lf -profile strict
proc ::xxx args {
set ::s0 $args
}
fcopy $in $out -command ::xxx
vwait ::s0
set ::s0
} -cleanup {
close $in
close $out
unset ::s0
} -match glob -result {0 {error writing "file*": invalid or incomplete multibyte or wide character}}
test io-52.24 {fcopy -size should always be characters} -setup {
set out [open utf8-fcopy-52.24.txt w]
fconfigure $out -encoding utf-8 -translation lf
puts $out "Á"
close $out
} -constraints {fcopy} -body {
set in [open utf8-fcopy-52.24.txt r]
set out [open utf8-fcopy-52.24.out.txt w+]
fconfigure $in -encoding utf-8 -profile tcl8
fconfigure $out -encoding utf-8 -profile tcl8
fcopy $in $out -size 1
seek $out 0
# a result of \xc3 means that only the first byte of the utf-8 encoding of
# Á made it into to the output file.
read $out
} -cleanup {
close $in
close $out
catch {file delete utf8-fcopy-52.24.txt}
catch {file delete utf8-fcopy-52.24.out.txt}
} -result Á
test io-53.1 {CopyData} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
fcopy $f1 $f2 -size 0
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
lappend result [file size $path(test1)]
} {0 0 0}
test io-53.2 {CopyData} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0
fconfigure $f2 -translation cr -encoding iso8859-1 -blocking 0
fcopy $f1 $f2 -command [namespace code {set s0}]
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
variable s0
vwait [namespace which -variable s0]
close $f1
close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
}
set result
} {0 0 ok}
test io-53.3 {CopyData: background read underflow} {stdio unix fcopy} {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts -nonewline $f1 {
puts ready
flush stdout ;# Don't assume line buffered!
fcopy stdin stdout -command { set x }
vwait x
set f [}
puts $f1 [list open $path(test1) w]]
puts $f1 {
fconfigure $f -translation lf
puts $f "done"
close $f
}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
set result [gets $f1]
puts $f1 line1
flush $f1
lappend result [gets $f1]
puts $f1 line2
flush $f1
lappend result [gets $f1]
close $f1
after 500
set f [open $path(test1)]
lappend result [read $f]
close $f
set result
} "ready line1 line2 {done\n}"
test io-53.4 {CopyData: background write overflow} {stdio fileevent fcopy} {
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
variable x
for {set x 0} {$x < 12} {incr x} {
append big $big
}
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
puts ready
fcopy stdin stdout -command { set x }
vwait x
}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
set result [gets $f1]
fconfigure $f1 -blocking 0
puts $f1 $big
flush $f1
set result ""
fileevent $f1 read [namespace code {
append result [read $f1 1024]
if {[string length $result] >= [string length $big]+1} {
set x done
}
}]
vwait [namespace which -variable x]
close $f1
set big {}
set x
} done
test io-53.4.1 {Bug 894da183c8} {stdio fcopy} {
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
variable x
for {set x 0} {$x < 12} {incr x} {
append big $big
}
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 [list file delete $path(test1)]
puts $f1 {
puts ready
set f [open io-53.4.1 w]
chan configure $f -translation lf
fcopy stdin $f -command { set x }
vwait x
close $f
}
puts $f1 "close \[[list open $path(test1) w]]"
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
set result [gets $f1]
fconfigure $f1 -blocking 0 -buffersize 125000 -translation lf
puts $f1 $big
fconfigure $f1 -blocking 1
close $f1
set big {}
while {[catch {glob $path(test1)}]} {after 50}
file delete $path(test1)
set check [file size io-53.4.1]
file delete io-53.4.1
set check
} 266241
set result {}
proc FcopyTestAccept {sock args} {
after 1000 "close $sock"
}
proc FcopyTestDone {bytes {error {}}} {
variable fcopyTestDone
if {[string length $error]} {
set fcopyTestDone 1
} else {
set fcopyTestDone 0
}
}
test io-53.5 {CopyData: error during fcopy} {socket fcopy} {
variable fcopyTestDone
set listen [socket -server [namespace code FcopyTestAccept] -myaddr 127.0.0.1 0]
set in [open $thisScript] ;# 126 K
set out [socket 127.0.0.1 [lindex [fconfigure $listen -sockname] 2]]
catch {unset fcopyTestDone}
close $listen ;# This means the socket open never really succeeds
fconfigure $in -encoding utf-8
fconfigure $out -encoding utf-8
fcopy $in $out -command [namespace code FcopyTestDone]
variable fcopyTestDone
if {![info exists fcopyTestDone]} {
vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g.
}
close $in
close $out
set fcopyTestDone ;# 1 for error condition
} 1
test io-53.6 {CopyData: error during fcopy} {stdio fcopy} {
variable fcopyTestDone
file delete $path(pipe)
file delete $path(test1)
catch {unset fcopyTestDone}
set f1 [open $path(pipe) w]
puts $f1 "exit 1"
close $f1
set in [open "|[list [interpreter] $path(pipe)]" r+]
set out [open $path(test1) w]
fcopy $in $out -command [namespace code FcopyTestDone]
variable fcopyTestDone
if {![info exists fcopyTestDone]} {
vwait [namespace which -variable fcopyTestDone]
}
catch {close $in}
close $out
set fcopyTestDone ;# 0 for plain end of file
} {0}
proc doFcopy {in out {bytes 0} {error {}}} {
variable fcopyTestDone
variable fcopyTestCount
incr fcopyTestCount $bytes
if {[string length $error]} {
set fcopyTestDone 1
} elseif {[eof $in]} {
set fcopyTestDone 0
} else {
# Delay next fcopy to wait for size>0 input bytes
after 100 [list fcopy $in $out -size 1000 \
-command [namespace code [list doFcopy $in $out]]]
}
}
test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio fcopy} {
variable fcopyTestDone
file delete $path(pipe)
catch {unset fcopyTestDone}
set fcopyTestCount 0
set f1 [open $path(pipe) w]
puts $f1 {
# Write 10 bytes / 10 msec
proc Write {count} {
puts -nonewline "1234567890"
if {[incr count -1]} {
after 10 [list Write $count]
} else {
set ::ready 1
}
}
fconfigure stdout -buffering none
Write 345 ;# 3450 bytes ~3.45 sec
vwait ready
exit 0
}
close $f1
set in [open "|[list [interpreter] $path(pipe) &]" r+]
set out [open $path(test1) w]
doFcopy $in $out
variable fcopyTestDone
if {![info exists fcopyTestDone]} {
vwait [namespace which -variable fcopyTestDone]
}
catch {close $in}
close $out
# -1=error 0=script error N=number of bytes
expr {($fcopyTestDone == 0) ? $fcopyTestCount : -1}
} {3450}
test io-53.8 {CopyData: async callback and error handling, Bug 1932639} -setup {
# copy progress callback. errors out intentionally
proc ::cmd args {
lappend ::RES "CMD $args"
error !STOP
}
# capture callback error here
proc ::bgerror args {
lappend ::RES "bgerror/OK $args"
set ::forever has-been-reached
return
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
} -constraints {stdio fcopy} -body {
# Record input size, so that result is always defined
lappend ::RES [file size $bar]
# Run the copy. Should not invoke -command now.
fcopy $f $g -size 2 -command ::cmd
# Check that -command was not called synchronously
set sbs [file size $bar]
lappend ::RES [expr {($sbs > 0) ? "sync/FAIL" : "sync/OK"}] $sbs
# Now let the async part happen. Should capture the error in cmd
# via bgerror. If not break the event loop via timer.
set token [after 1000 {
lappend ::RES {bgerror/FAIL timeout}
set ::forever has-been-reached
}]
vwait ::forever
catch {after cancel $token}
# Report
set ::RES
} -cleanup {
close $f
close $g
catch {unset ::RES}
catch {unset ::forever}
rename ::cmd {}
rename ::bgerror {}
removeFile foo
removeFile bar
} -result {0 sync/OK 0 {CMD 2} {bgerror/OK !STOP}}
test io-53.8a {CopyData: async callback and error handling, Bug 1932639, at eof} -setup {
# copy progress callback. errors out intentionally
proc ::cmd args {
lappend ::RES "CMD $args"
set ::forever has-been-reached
return
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
} -constraints {stdio fcopy} -body {
# Initialize and force eof on the input.
seek $f 0 end ; read $f 1
set ::RES [eof $f]
# Run the copy. Should not invoke -command now.
fcopy $f $g -size 2 -command ::cmd
# Check that -command was not called synchronously
lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}]
# Now let the async part happen. Should capture the eof in cmd
# If not break the event loop via timer.
set token [after 1000 {
lappend ::RES {cmd/FAIL timeout}
set ::forever has-been-reached
}]
vwait ::forever
catch {after cancel $token}
# Report
set ::RES
} -cleanup {
close $f
close $g
catch {unset ::RES}
catch {unset ::forever}
rename ::cmd {}
removeFile foo
removeFile bar
} -result {1 sync/OK {CMD 0}}
test io-53.8b {CopyData: async callback and -size 0} -setup {
# copy progress callback. errors out intentionally
proc ::cmd args {
lappend ::RES "CMD $args"
set ::forever has-been-reached
return
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
} -constraints {stdio fcopy} -body {
set ::RES {}
# Run the copy. Should not invoke -command now.
fcopy $f $g -size 0 -command ::cmd
# Check that -command was not called synchronously
lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}]
# Now let the async part happen. Should capture the eof in cmd
# If not break the event loop via timer.
set token [after 1000 {
lappend ::RES {cmd/FAIL timeout}
set ::forever has-been-reached
}]
vwait ::forever
catch {after cancel $token}
# Report
set ::RES
} -cleanup {
close $f
close $g
catch {unset ::RES}
catch {unset ::forever}
rename ::cmd {}
removeFile foo
removeFile bar
} -result {sync/OK {CMD 0}}
test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup {
set out [makeFile {} out]
set err [makeFile {} err]
set pipe [open "|[list [info nameofexecutable] 2> $err]" r+]
fconfigure $pipe -translation binary -buffering line
puts $pipe {
fconfigure stdout -translation binary -buffering line
puts stderr Waiting...
after 1000
foreach x {a b c} {
puts stderr Looping...
puts $x
after 500
}
proc bye args {
if {[gets stdin line]<0} {
puts stderr "CHILD: EOF detected, exiting"
exit
} else {
puts stderr "CHILD: ignoring line: $line"
}
}
puts stderr Now-sleeping-forever
fileevent stdin readable bye
vwait forever
}
proc ::done args {
set ::forever OK
return
}
set ::forever {}
set out [open $out w]
} -constraints {stdio fcopy} -body {
fcopy $pipe $out -size 6 -command ::done
set token [after 5000 {
set ::forever {fcopy hangs}
}]
vwait ::forever
catch {after cancel $token}
set ::forever
} -cleanup {
close $pipe
rename ::done {}
after 1000; # Give Windows time to kill the process
catch {close $out}
catch {removeFile out}
catch {removeFile err}
catch {unset ::forever}
} -result OK
test io-53.10 {Bug 1350564, multi-directional fcopy} -setup {
set err [makeFile {} err]
set pipe [open "|[list [info nameofexecutable] 2> $err]" r+]
fconfigure $pipe -translation binary -buffering line
puts $pipe {
fconfigure stderr -buffering line
# Kill server when pipe closed by invoker.
proc bye args {
if {![eof stdin]} { gets stdin ; return }
puts stderr BYE
exit
}
# Server code. Bi-directional copy between 2 sockets.
proc geof {sok} {
puts stderr DONE/$sok
close $sok
}
proc new {sok args} {
puts stderr NEW/$sok
global l srv
fconfigure $sok -translation binary -buffering none
lappend l $sok
if {[llength $l]==2} {
close $srv
foreach {a b} $l break
fcopy $a $b -command [list geof $a]
fcopy $b $a -command [list geof $b]
puts stderr 2COPY
}
puts stderr ...
}
puts stderr SRV
set l {}
set srv [socket -server new -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $srv -sockname] 2]
puts stderr WAITING
fileevent stdin readable bye
puts "OK $port"
vwait forever
}
# wait for OK from server.
lassign [gets $pipe] ok port
# Now the two clients.
proc ::done {sock} {
if {[eof $sock]} { close $sock ; return }
lappend ::forever [gets $sock]
return
}
set a [socket 127.0.0.1 $port]
set b [socket 127.0.0.1 $port]
fconfigure $a -translation binary -buffering none
fconfigure $b -translation binary -buffering none
fileevent $a readable [list ::done $a]
fileevent $b readable [list ::done $b]
} -constraints {stdio fcopy} -body {
# Now pass data through the server in both directions.
set ::forever {}
puts $a AB
vwait ::forever
puts $b BA
vwait ::forever
set ::forever
} -cleanup {
catch {close $a}
catch {close $b}
close $pipe
rename ::done {}
after 1000 ;# Give Windows time to kill the process
removeFile err
catch {unset ::forever}
} -result {AB BA}
test io-53.11 {Bug 2895565} -setup {
set in [makeFile {} in]
set f [open $in w]
fconfigure $f -encoding utf-8 -translation binary
puts -nonewline $f [string repeat "Ho hum\n" 11]
close $f
set inChan [open $in r]
fconfigure $inChan -translation binary
set out [makeFile {} out]
set outChan [open $out w]
fconfigure $outChan -encoding cp1252 -translation crlf
proc CopyDone {bytes args} {
variable done
if {[llength $args]} {
set done "Error: '[lindex $args 0]' after $bytes bytes copied"
} else {
set done "$bytes bytes copied"
}
}
} -body {
variable done
after 2000 [list set [namespace which -variable done] timeout]
fcopy $inChan $outChan -size 40 -command [namespace which CopyDone]
vwait [namespace which -variable done]
set done
} -cleanup {
close $outChan
close $inChan
removeFile out
removeFile in
} -result {40 bytes copied}
test io-53.12.0 {CopyData: foreground short reads, aka bug 3096275} {stdio unix fcopy} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts -nonewline $f1 {
fconfigure stdin -translation binary -blocking 0
fconfigure stdout -buffering none -translation binary
fcopy stdin stdout
}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f1 -translation binary -buffering none
puts -nonewline $f1 A
after 2000 {set ::done timeout}
fileevent $f1 readable {set ::done ok}
vwait ::done
set ch [read $f1 1]
close $f1
list $::done $ch
} {ok A}
test io-53.12.1 {
Issue 9ca87e6286262a62.
CopyData: foreground short reads via ReadChars().
Related to report 3096275 for ReadBytes().
Prior to the fix this test waited forever for read() to return.
} {stdio unix fcopy} {
file delete $path(output)
set f1 [open $path(output) w]
puts -nonewline $f1 {
chan configure stdin -encoding iso8859-1 -translation lf -buffering none
fcopy stdin stdout
}
close $f1
set f1 [open "|[list [info nameofexecutable] $path(output)]" r+]
try {
chan configure $f1 -encoding utf-8 -buffering none
puts -nonewline $f1 A
set ch [read $f1 1]
} finally {
if {$f1 in [chan names]} {
close $f1
}
}
lindex $ch
} A
test io-53.13 {TclCopyChannel: read error reporting} -setup {
proc driver {cmd args} {
variable buffer
variable index
set chan [lindex $args 0]
switch -- $cmd {
initialize {
return {initialize finalize watch read}
}
finalize {
return
}
watch {}
read {
error FAIL
}
}
}
set outFile [makeFile {} out]
} -body {
set in [chan create read [namespace which driver]]
chan configure $in -translation binary
set out [open $outFile wb]
chan copy $in $out
} -cleanup {
catch {close $in}
catch {close $out}
removeFile out
rename driver {}
} -result {error reading "rc*": *} -returnCodes error -match glob
test io-53.14 {TclCopyChannel: write error reporting} -setup {
proc driver {cmd args} {
variable buffer
variable index
set chan [lindex $args 0]
switch -- $cmd {
initialize {
return {initialize finalize watch write}
}
finalize {
return
}
watch {}
write {
error FAIL
}
}
}
set inFile [makeFile {aaa} in]
} -body {
set in [open $inFile rb]
set out [chan create write [namespace which driver]]
chan configure $out -translation binary
chan copy $in $out
} -cleanup {
catch {close $in}
catch {close $out}
removeFile in
rename driver {}
} -result {error writing "*": *} -returnCodes error -match glob
test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup {
proc driver {cmd args} {
variable buffer
variable index
variable blocked
set chan [lindex $args 0]
switch -- $cmd {
initialize {
set index($chan) 0
set buffer($chan) [encoding convertto utf-8 \
[string repeat a 100]]
set blocked($chan) 1
return {initialize finalize watch read}
}
finalize {
unset index($chan) buffer($chan) blocked($chan)
return
}
watch {}
read {
if {$blocked($chan)} {
set blocked($chan) [expr {!$blocked($chan)}]
return -code error EAGAIN
}
set n [lindex $args 1]
set new [expr {$index($chan) + $n}]
set result [string range $buffer($chan) $index($chan) $new-1]
set index($chan) $new
return $result
}
}
}
set c [chan create read [namespace which driver]]
chan configure $c -encoding utf-8
set out [makeFile {} out]
set outChan [open $out w]
chan configure $outChan -encoding utf-8
} -body {
chan copy $c $outChan
} -cleanup {
close $outChan
close $c
removeFile out
} -result 100
test io-53.16 {[ed29c4da21] MBRead: fblocked seen as error} -setup {
proc driver {cmd args} {
variable buffer
variable index
variable blocked
set chan [lindex $args 0]
switch -- $cmd {
initialize {
set index($chan) 0
set buffer($chan) [encoding convertto utf-8 \
[string repeat a 100]]
set blocked($chan) 1
return {initialize finalize watch read}
}
finalize {
unset index($chan) buffer($chan) blocked($chan)
return
}
watch {}
read {
if {$blocked($chan)} {
set blocked($chan) [expr {!$blocked($chan)}]
return -code error EAGAIN
}
set n [lindex $args 1]
set new [expr {$index($chan) + $n}]
set result [string range $buffer($chan) $index($chan) $new-1]
set index($chan) $new
return $result
}
}
}
set c [chan create read [namespace which driver]]
chan configure $c -encoding utf-8 -translation lf
set out [makeFile {} out]
set outChan [open $out w]
chan configure $outChan -encoding utf-8 -translation lf
} -body {
chan copy $c $outChan
} -cleanup {
close $outChan
close $c
removeFile out
} -result 100
test io-53.17 {[7c187a3773] MBWrite: proper inQueueTail handling} -setup {
proc driver {cmd args} {
variable buffer
variable index
set chan [lindex $args 0]
switch -- $cmd {
initialize {
set index($chan) 0
set buffer($chan) [encoding convertto utf-8 \
line\n[string repeat a 100]line\n]
return {initialize finalize watch read}
}
finalize {
unset index($chan) buffer($chan)
return
}
watch {}
read {
set n [lindex $args 1]
set new [expr {$index($chan) + $n}]
set result [string range $buffer($chan) $index($chan) $new-1]
set index($chan) $new
return $result
}
}
}
set c [chan create read [namespace which driver]]
chan configure $c -encoding utf-8 -translation lf -buffersize 107
set out [makeFile {} out]
set outChan [open $out w]
chan configure $outChan -encoding utf-8 -translation lf
} -body {
list [gets $c] [chan copy $c $outChan -size 100] [gets $c]
} -cleanup {
close $outChan
close $c
removeFile out
} -result {line 100 line}
test io-54.1 {Recursive channel events} {socket fileevent notWinCI} {
# This test checks to see if file events are delivered during recursive
# event loops when there is buffered data on the channel.
proc accept {s a p} {
variable as
fconfigure $s -translation lf
puts $s "line 1\nline2\nline3"
flush $s
set as $s
}
proc readit {s next} {
variable x
variable result
lappend result $next
if {$next == 1} {
fileevent $s readable [namespace code [list readit $s 2]]
vwait [namespace which -variable x]
}
incr x
}
set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
# We need to delay on some systems until the creation of the
# server socket completes.
set done 0
for {set i 0} {$i < 10} {incr i} {
if {![catch {set cs [socket 127.0.0.1 [lindex [fconfigure $ss -sockname] 2]]}]} {
set done 1
break
}
after 100
}
if {$done == 0} {
close $ss
error "failed to connect to server"
}
variable result {}
variable x 0
variable as
vwait [namespace which -variable as]
fconfigure $cs -translation lf
lappend result [gets $cs]
fconfigure $cs -blocking off
fileevent $cs readable [namespace code [list readit $cs 1]]
set a [after 2000 [namespace code { set x failure }]]
vwait [namespace which -variable x]
after cancel $a
close $as
close $ss
close $cs
list $result $x
} {{{line 1} 1 2} 2}
test io-54.2 {Testing for busy-wait in recursive channel events} {socket fileevent} {
set accept {}
set after {}
variable s [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
proc accept {s a p} {
variable counter
variable accept
set accept $s
set counter 0
fconfigure $s -blocking off -buffering line -translation lf
fileevent $s readable [namespace code "doit $s"]
}
proc doit {s} {
variable counter
variable after
incr counter
set l [gets $s]
if {"$l" == ""} {
fileevent $s readable [namespace code "doit1 $s"]
set after [after 1000 [namespace code newline]]
}
}
proc doit1 {s} {
variable counter
variable accept
incr counter
set l [gets $s]
close $s
set accept {}
}
proc producer {} {
variable s
variable writer
set writer [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
fconfigure $writer -buffering line
puts -nonewline $writer hello
flush $writer
}
proc newline {} {
variable done
variable writer
puts $writer hello
flush $writer
set done 1
}
producer
variable done
vwait [namespace which -variable done]
close $writer
close $s
after cancel $after
if {$accept != {}} {close $accept}
set counter
} 1
set path(fooBar) [makeFile {} fooBar]
test io-55.1 {ChannelEventScriptInvoker: deletion} -constraints {
fileevent
} -setup {
variable x
proc eventScript {fd} {
variable x
close $fd
error "planned error"
set x whoops
}
proc myHandler args {
variable x got_error
}
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
} -body {
set f [open $path(fooBar) w]
fileevent $f writable [namespace code [list eventScript $f]]
variable x not_done
vwait [namespace which -variable x]
set x
} -cleanup {
interp bgerror {} $handler
} -result {got_error}
test io-56.1 {ChannelTimerProc} {testchannelevent} {
set f [open $path(fooBar) w]
puts $f "this is a test"
close $f
set f [open $path(fooBar) r]
testchannelevent $f add readable [namespace code {
read $f 1
incr x
}]
variable x 0
vwait [namespace which -variable x]
vwait [namespace which -variable x]
set result $x
testchannelevent $f set 0 none
after idle [namespace code {set y done}]
variable y
vwait [namespace which -variable y]
close $f
lappend result $y
} {2 done}
test io-57.1 {buffered data and file events, gets} {fileevent} {
proc accept {sock args} {
variable s2
set s2 $sock
}
set server [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
set s [socket 127.0.0.1 [lindex [fconfigure $server -sockname] 2]]
variable s2
vwait [namespace which -variable s2]
update
fileevent $s2 readable [namespace code {lappend result readable}]
puts $s "12\n34567890"
flush $s
variable result [gets $s2]
after 1000 [namespace code {lappend result timer}]
vwait [namespace which -variable result]
lappend result [gets $s2]
vwait [namespace which -variable result]
close $s
close $s2
close $server
set result
} {12 readable 34567890 timer}
test io-57.2 {buffered data and file events, read} {fileevent} {
proc accept {sock args} {
variable s2
set s2 $sock
}
set server [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
set s [socket 127.0.0.1 [lindex [fconfigure $server -sockname] 2]]
variable s2
vwait [namespace which -variable s2]
update
fileevent $s2 readable [namespace code {lappend result readable}]
puts -nonewline $s "1234567890"
flush $s
variable result [read $s2 1]
after 1000 [namespace code {lappend result timer}]
vwait [namespace which -variable result]
lappend result [read $s2 9]
vwait [namespace which -variable result]
close $s
close $s2
close $server
set result
} {1 readable 234567890 timer}
test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin fileevent} {
set out [open $path(script) w]
puts $out {
puts "normal message from pipe"
puts stderr "error message from pipe"
exit 1
}
proc readit {pipe} {
variable x
variable result
if {[eof $pipe]} {
set x [catch {close $pipe} line]
lappend result catch $line
} else {
gets $pipe line
lappend result gets $line
}
}
close $out
set pipe [open "|[list [interpreter] $path(script)]" r]
fileevent $pipe readable [namespace code [list readit $pipe]]
variable x ""
set result ""
vwait [namespace which -variable x]
list $x $result
} {1 {gets {normal message from pipe} gets {} catch {error message from pipe}}}
test io-59.1 {Thread reference of channels} {testmainthread testchannel} {
# TIP #10
# More complicated tests (like that the reference changes as a
# channel is moved from thread to thread) can be done only in the
# extension which fully implements the moving of channels between
# threads, i.e. 'Threads'.
set f [open $path(longfile) r]
set result [testchannel mthread $f]
close $f
string equal $result [testmainthread]
} {1}
test io-60.1 {writing illegal utf sequences} {fileevent testbytestring} {
# This test will hang in older revisions of the core.
set out [open $path(script) w]
puts $out "catch {load $::tcltestlib Tcltest}"
puts $out {
puts ABC[testbytestring \xE2]
exit 1
}
proc readit {pipe} {
variable x
variable result
if {[eof $pipe]} {
set x [catch {close $pipe} line]
lappend result catch $line
} else {
gets $pipe line
lappend result gets $line
}
}
close $out
set pipe [open "|[list [interpreter] $path(script)]" r]
fileevent $pipe readable [namespace code [list readit $pipe]]
variable x ""
set result ""
vwait [namespace which -variable x]
# cut of the remainder of the error stack, especially the filename
set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]]
list $x $result
} {1 {gets ABC catch {error writing "stdout": invalid or incomplete multibyte or wide character}}}
test io-61.1 {Reset eof state after changing the eof char} -setup {
set datafile [makeFile {} eofchar]
set f [open $datafile w]
fconfigure $f -translation binary
puts -nonewline $f [string repeat "Ho hum\n" 11]
puts $f =
set line [string repeat "Ge gla " 4]
puts -nonewline $f [string repeat [string trimright $line]\n 834]
close $f
} -body {
set f [open $datafile r]
fconfigure $f -eofchar =
set res {}
lappend res [read $f; tell $f]
fconfigure $f -eofchar {}
lappend res [read $f 1]
lappend res [read $f; tell $f]
# Any seek zaps the internals into a good state.
#seek $f 0 start
#seek $f 0 current
#lappend res [read $f; tell $f]
close $f
set res
} -cleanup {
removeFile eofchar
} -result {77 = 23431}
# Test the cutting and splicing of channels, this is incidentally the
# attach/detach facility of package Thread, but __without any
# safeguards__. It can also be used to emulate transfer of channels
# between threads, and is used for that here.
test io-70.0 {Cutting & Splicing channels} {testchannel} {
set f [makeFile {... dummy ...} cutsplice]
set c [open $f r]
set res {}
lappend res [catch {seek $c 0 start}]
testchannel cut $c
lappend res [catch {seek $c 0 start}]
testchannel splice $c
lappend res [catch {seek $c 0 start}]
close $c
removeFile cutsplice
set res
} {0 1 0}
test io-70.1 {Transfer channel} {testchannel thread} {
set f [makeFile {... dummy ...} cutsplice]
set c [open $f r]
set res {}
lappend res [catch {seek $c 0 start}]
testchannel cut $c
lappend res [catch {seek $c 0 start}]
set tid [thread::create -preserved]
thread::send $tid [list set c $c]
thread::send $tid {load {} Tcltest}
lappend res [thread::send $tid {
testchannel splice $c
set res [catch {seek $c 0 start}]
close $c
set res
}]
thread::release $tid
removeFile cutsplice
set res
} {0 1 0}
# ### ### ### ######### ######### #########
foreach {n msg expected} {
0 {} {}
1 {{message only}} {{message only}}
2 {-options x} {-options x}
3 {-options {x y} {the message}} {-options {x y} {the message}}
4 {-code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
5 {-code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
6 {-code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
7 {-code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
8 {-code error -level 0 -f ba snarf} {-code error -level 0 -f ba snarf}
9 {-code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
10 {-code error -level 5 -f ba snarf} {-code error -level 0 -f ba snarf}
11 {-code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
12 {-code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
13 {-code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
14 {-code 1 -level 0 -f ba} {-code 1 -level 0 -f ba}
15 {-code 0 -level 0 -f ba} {-code 1 -level 0 -f ba}
16 {-code 1 -level 5 -f ba} {-code 1 -level 0 -f ba}
17 {-code 0 -level 5 -f ba} {-code 1 -level 0 -f ba}
18 {-code error -level 0 -f ba} {-code error -level 0 -f ba}
19 {-code ok -level 0 -f ba} {-code 1 -level 0 -f ba}
20 {-code error -level 5 -f ba} {-code error -level 0 -f ba}
21 {-code ok -level 5 -f ba} {-code 1 -level 0 -f ba}
22 {-code boss -level 0 -f ba} {-code 1 -level 0 -f ba}
23 {-code boss -level 5 -f ba} {-code 1 -level 0 -f ba}
24 {-code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
25 {-code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
26 {-code error -level X -f ba snarf} {-code error -level 0 -f ba snarf}
27 {-code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
28 {-code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
29 {-code 1 -level X -f ba} {-code 1 -level 0 -f ba}
30 {-code 0 -level X -f ba} {-code 1 -level 0 -f ba}
31 {-code error -level X -f ba} {-code error -level 0 -f ba}
32 {-code ok -level X -f ba} {-code 1 -level 0 -f ba}
33 {-code boss -level X -f ba} {-code 1 -level 0 -f ba}
34 {-code 1 -code 1 -level 0 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf}
35 {-code 1 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
36 {-code 1 -code 1 -level 5 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf}
37 {-code 1 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
38 {-code 1 -code error -level 0 -f ba snarf} {-code 1 -code error -level 0 -f ba snarf}
39 {-code 1 -code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
40 {-code 1 -code error -level 5 -f ba snarf} {-code 1 -code error -level 0 -f ba snarf}
41 {-code 1 -code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
42 {-code 1 -code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
43 {-code 1 -code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
44 {-code 1 -code 1 -level 0 -f ba} {-code 1 -code 1 -level 0 -f ba}
45 {-code 1 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba}
46 {-code 1 -code 1 -level 5 -f ba} {-code 1 -code 1 -level 0 -f ba}
47 {-code 1 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba}
48 {-code 1 -code error -level 0 -f ba} {-code 1 -code error -level 0 -f ba}
49 {-code 1 -code ok -level 0 -f ba} {-code 1 -level 0 -f ba}
50 {-code 1 -code error -level 5 -f ba} {-code 1 -code error -level 0 -f ba}
51 {-code 1 -code ok -level 5 -f ba} {-code 1 -level 0 -f ba}
52 {-code 1 -code boss -level 0 -f ba} {-code 1 -level 0 -f ba}
53 {-code 1 -code boss -level 5 -f ba} {-code 1 -level 0 -f ba}
54 {-code 1 -code 1 -level X -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf}
55 {-code 1 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
56 {-code 1 -code error -level X -f ba snarf} {-code 1 -code error -level 0 -f ba snarf}
57 {-code 1 -code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
58 {-code 1 -code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
59 {-code 1 -code 1 -level X -f ba} {-code 1 -code 1 -level 0 -f ba}
60 {-code 1 -code 0 -level X -f ba} {-code 1 -level 0 -f ba}
61 {-code 1 -code error -level X -f ba} {-code 1 -code error -level 0 -f ba}
62 {-code 1 -code ok -level X -f ba} {-code 1 -level 0 -f ba}
63 {-code 1 -code boss -level X -f ba} {-code 1 -level 0 -f ba}
64 {-code 0 -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
65 {-code 0 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
66 {-code 0 -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
67 {-code 0 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
68 {-code 0 -code error -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
69 {-code 0 -code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
70 {-code 0 -code error -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
71 {-code 0 -code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
72 {-code 0 -code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
73 {-code 0 -code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
74 {-code 0 -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba}
75 {-code 0 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba}
76 {-code 0 -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba}
77 {-code 0 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba}
78 {-code 0 -code error -level 0 -f ba} {-code 1 -level 0 -f ba}
79 {-code 0 -code ok -level 0 -f ba} {-code 1 -level 0 -f ba}
80 {-code 0 -code error -level 5 -f ba} {-code 1 -level 0 -f ba}
81 {-code 0 -code ok -level 5 -f ba} {-code 1 -level 0 -f ba}
82 {-code 0 -code boss -level 0 -f ba} {-code 1 -level 0 -f ba}
83 {-code 0 -code boss -level 5 -f ba} {-code 1 -level 0 -f ba}
84 {-code 0 -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
85 {-code 0 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
86 {-code 0 -code error -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
87 {-code 0 -code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
88 {-code 0 -code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
89 {-code 0 -code 1 -level X -f ba} {-code 1 -level 0 -f ba}
90 {-code 0 -code 0 -level X -f ba} {-code 1 -level 0 -f ba}
91 {-code 0 -code error -level X -f ba} {-code 1 -level 0 -f ba}
92 {-code 0 -code ok -level X -f ba} {-code 1 -level 0 -f ba}
93 {-code 0 -code boss -level X -f ba} {-code 1 -level 0 -f ba}
94 {-code 1 -code 1 -level 0 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf}
95 {-code 0 -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
96 {-code 1 -code 1 -level 5 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf}
97 {-code 0 -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
98 {-code error -code 1 -level 0 -f ba snarf} {-code error -code 1 -level 0 -f ba snarf}
99 {-code ok -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
a0 {-code error -code 1 -level 5 -f ba snarf} {-code error -code 1 -level 0 -f ba snarf}
a1 {-code ok -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
a2 {-code boss -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
a3 {-code boss -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
a4 {-code 1 -code 1 -level 0 -f ba} {-code 1 -code 1 -level 0 -f ba}
a5 {-code 0 -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba}
a6 {-code 1 -code 1 -level 5 -f ba} {-code 1 -code 1 -level 0 -f ba}
a7 {-code 0 -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba}
a8 {-code error -code 1 -level 0 -f ba} {-code error -code 1 -level 0 -f ba}
a9 {-code ok -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba}
b0 {-code error -code 1 -level 5 -f ba} {-code error -code 1 -level 0 -f ba}
b1 {-code ok -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba}
b2 {-code boss -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba}
b3 {-code boss -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba}
b4 {-code 1 -code 1 -level X -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf}
b5 {-code 0 -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
b6 {-code error -code 1 -level X -f ba snarf} {-code error -code 1 -level 0 -f ba snarf}
b7 {-code ok -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
b8 {-code boss -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
b9 {-code 1 -code 1 -level X -f ba} {-code 1 -code 1 -level 0 -f ba}
c0 {-code 0 -code 1 -level X -f ba} {-code 1 -level 0 -f ba}
c1 {-code error -code 1 -level X -f ba} {-code error -code 1 -level 0 -f ba}
c2 {-code ok -code 1 -level X -f ba} {-code 1 -level 0 -f ba}
c3 {-code boss -code 1 -level X -f ba} {-code 1 -level 0 -f ba}
c4 {-code 1 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
c5 {-code 0 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
c6 {-code 1 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
c7 {-code 0 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
c8 {-code error -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
c9 {-code ok -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
d0 {-code error -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
d1 {-code ok -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
d2 {-code boss -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf}
d3 {-code boss -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf}
d4 {-code 1 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba}
d5 {-code 0 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba}
d6 {-code 1 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba}
d7 {-code 0 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba}
d8 {-code error -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba}
d9 {-code ok -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba}
e0 {-code error -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba}
e1 {-code ok -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba}
e2 {-code boss -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba}
e3 {-code boss -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba}
e4 {-code 1 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
e5 {-code 0 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
e6 {-code error -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
e7 {-code ok -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
e8 {-code boss -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf}
e9 {-code 1 -code 0 -level X -f ba} {-code 1 -level 0 -f ba}
f0 {-code 0 -code 0 -level X -f ba} {-code 1 -level 0 -f ba}
f1 {-code error -code 0 -level X -f ba} {-code 1 -level 0 -f ba}
f2 {-code ok -code 0 -level X -f ba} {-code 1 -level 0 -f ba}
f3 {-code boss -code 0 -level X -f ba} {-code 1 -level 0 -f ba}
} {
test io-71.$n {Tcl_SetChannelError} {testchannel} {
set f [makeFile {... dummy ...} cutsplice]
set c [open $f r]
set res [testchannel setchannelerror $c [lrange $msg 0 end]]
close $c
removeFile cutsplice
set res
} [lrange $expected 0 end]
test io-72.$n {Tcl_SetChannelErrorInterp} {testchannel} {
set f [makeFile {... dummy ...} cutsplice]
set c [open $f r]
set res [testchannel setchannelerrorinterp $c [lrange $msg 0 end]]
close $c
removeFile cutsplice
set res
} [lrange $expected 0 end]
}
test io-73.1 {channel Tcl_Obj SetChannelFromAny} {} {
# Test for Bug 1847044 - don't spoil type unless we have a valid channel
catch {close [lreplace [list a] 0 end]}
} {1}
test io-73.2 {channel Tcl_Obj SetChannelFromAny, bug 2407783} -setup {
# Invalidate internalrep of 'channel' Tcl_Obj when transiting between interpreters.
set f [open [info script] r]
} -body {
interp create foo
seek $f 0
set code [catch {interp eval foo [list seek $f 0]} msg]
# The string map converts the changing channel handle to a fixed string
list $code [string map [list $f @@] $msg]
} -cleanup {
close $f
} -result {1 {can not find channel named "@@"}}
test io-73.3 {[5adc350683] [gets] after EOF} -setup {
set fn [makeFile {} io-73.3]
set rfd [open $fn r]
set wfd [open $fn a]
chan configure $wfd -buffering line
read $rfd
} -body {
set result [eof $rfd]
puts $wfd "more data"
lappend result [eof $rfd]
lappend result [gets $rfd]
lappend result [eof $rfd]
lappend result [gets $rfd]
lappend result [eof $rfd]
} -cleanup {
close $wfd
close $rfd
removeFile io-73.3
} -result {1 1 {more data} 0 {} 1}
test io-73.4 {[5adc350683] [read] after EOF} -setup {
set fn [makeFile {} io-73.4]
set rfd [open $fn r]
set wfd [open $fn a]
chan configure $wfd -buffering line
read $rfd
} -body {
set result [eof $rfd]
puts $wfd "more data"
lappend result [eof $rfd]
lappend result [read $rfd]
lappend result [eof $rfd]
} -cleanup {
close $wfd
close $rfd
removeFile io-73.4
} -result {1 1 {more data
} 1}
test io-73.5 {effect of eof on encoding end flags} -setup {
set fn [makeFile {} io-73.5]
set rfd [open $fn r]
set wfd [open $fn a]
chan configure $wfd -buffering none -translation binary
chan configure $rfd -buffersize 5 -encoding utf-8
read $rfd
} -body {
set result [eof $rfd]
puts -nonewline $wfd more\xC2\xA0data
lappend result [eof $rfd]
lappend result [read $rfd]
lappend result [eof $rfd]
} -cleanup {
close $wfd
close $rfd
removeFile io-73.5
} -result [list 1 1 more\xA0data 1]
test io-74.1 {[104f2885bb] improper cache validity check} -setup {
set fn [makeFile {} io-74.1]
set rfd [open $fn r]
testobj freeallvars
interp create child
} -constraints testobj -body {
teststringobj set 1 [string range $rfd 0 end]
read [teststringobj get 1]
testobj duplicate 1 2
interp transfer {} $rfd child
catch {read [teststringobj get 1]}
read [teststringobj get 2]
} -cleanup {
interp delete child
testobj freeallvars
removeFile io-74.1
} -returnCodes error -match glob -result {can not find channel named "*"}
test io-75.1 {multibyte encoding error read results in raw bytes (-profile tcl8)} -setup {
set fn [makeFile {} io-75.1]
set f [open $fn w+]
fconfigure $f -translation binary
# In UTF-8, a byte 0xCx starts a multibyte sequence and must be followed
# by a byte > 0x7F. This is violated to get an invalid sequence.
puts -nonewline $f A\xC0\x40
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -profile tcl8 -buffering none
} -body {
set d [read $f]
binary scan $d H* hd
set hd
} -cleanup {
close $f
removeFile io-75.1
} -result 41c040
test io-75.2 {unrepresentable character write passes and is replaced by ? (-profile tcl8)} -setup {
set fn [makeFile {} io-75.2]
set f [open $fn w+]
fconfigure $f -encoding iso8859-1 -profile tcl8
} -body {
puts -nonewline $f A\u2022
flush $f
seek $f 0
read $f
} -cleanup {
close $f
removeFile io-75.2
} -result A?
# Incomplete sequence test.
# This error may IMHO only be detected with the close.
# But the read already returns the incomplete sequence.
test io-75.3 {incomplete multibyte encoding read is ignored (-profile tcl8)} -setup {
set fn [makeFile {} io-75.3]
set f [open $fn w+]
fconfigure $f -translation binary
puts -nonewline $f "A\xC0"
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -profile tcl8
} -body {
set d [read $f]
binary scan $d H* hd
set hd
} -cleanup {
close $f
removeFile io-75.3
} -result 41c0
# As utf-8 has a special treatment in multi-byte decoding, also test another
# one.
test io-75.4 {shiftjis encoding error read results in raw bytes (-profile tcl8)} -setup {
set fn [makeFile {} io-75.4]
set f [open $fn w+]
fconfigure $f -translation binary
# In shiftjis, \x81 starts a two-byte sequence.
# But 2nd byte \xFF is not allowed
puts -nonewline $f A\x81\xFFA
flush $f
seek $f 0
fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -profile tcl8
} -body {
set d [read $f]
binary scan $d H* hd
set hd
} -cleanup {
close $f
removeFile io-75.4
} -result 4181ff41
test io-75.5 {invalid utf-8 encoding read is ignored (-profile tcl8)} -setup {
set fn [makeFile {} io-75.5]
set f [open $fn w+]
fconfigure $f -translation binary
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -profile tcl8
} -body {
set d [read $f]
binary scan $d H* hd
set hd
} -cleanup {
close $f
removeFile io-75.5
} -result 4181
test io-75.6.read {invalid utf-8 encoding, read is not ignored (-encodingstrict 1)} -setup {
set fn [makeFile {} io-75.6]
set f [open $fn w+]
fconfigure $f -encoding binary
# \x81 is invalid in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf \
-profile strict
} -body {
set status [catch {read $f} cres copts]
set d [dict get $copts -result read]
binary scan $d H* hd
lappend hd $status $cres
} -cleanup {
close $f
removeFile io-75.6
} -match glob -result {41 1 {error reading "file*":\
invalid or incomplete multibyte or wide character}}
test io-75.6.gets {invalid utf-8 encoding, gets is not ignored (-profile strict)} -setup {
set fn [makeFile {} io-75.6]
set f [open $fn w+]
fconfigure $f -translation binary
# \x81 is an incomplete byte sequence in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none \
-translation lf -profile strict
} -body {
gets $f
} -cleanup {
close $f
removeFile io-75.6
} -match glob -returnCodes 1 -result {error reading "file*":\
invalid or incomplete multibyte or wide character}
test io-75.6.1 {invalid utf-8 encoding, blocking gets is not ignored (-profile strict)} -setup {
set fn [makeFile {} io-75.6.1]
set f [open $fn w+]
fconfigure $f -translation binary
# utf-8: \xC3 requires a 2nd byte > x80, but <x80 is delivered
puts -nonewline $f A\xC3B
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none \
-translation lf -profile strict
} -body {
gets $f
} -cleanup {
close $f
removeFile io-75.6.1
} -match glob -returnCodes 1 -result {error reading "file*":\
invalid or incomplete multibyte or wide character}
test io-75.6.2 {invalid utf-8 encoding, blocking gets is not ignored (-profile strict), recover functionality} -setup {
set fn [makeFile {} io-75.6.2]
set f [open $fn w+]
fconfigure $f -translation binary
# utf-8: \xC3 requires a 2nd byte > x80, but <x80 is delivered
puts -nonewline $f A\xC3B
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none \
-translation lf -profile strict
} -body {
set l {}
lappend l [catch {gets $f}]
lappend l [tell $f]
fconfigure $f -translation binary
lappend l [expr {[gets $f] eq "A\xC3B"}]
} -cleanup {
close $f
removeFile io-75.6.2
} -match glob -returnCodes 0 -result {1 0 1}
# TCL ticket c4eb46a196: non blocking case had endless loop, so test it
test io-75.6.3 {invalid utf-8 encoding, non blocking gets is not ignored (-profile strict)} -setup {
set fn [makeFile {} io-75.6.3]
set f [open $fn w+]
fconfigure $f -translation binary
# utf-8: \xC3 requires a 2nd byte > x80, but <x80 is delivered
puts -nonewline $f A\xC3B
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none \
-translation lf -profile strict -blocking 0
} -body {
gets $f
} -cleanup {
close $f
removeFile io-75.6.3
} -match glob -returnCodes 1 -result {error reading "file*":\
invalid or incomplete multibyte or wide character}
test io-75.6.4 {incomplete utf-8 encoding, non blocking gets is not ignored (-profile strict)} -setup {
set fn [makeFile {} io-75.6.4]
set f [open $fn w+]
fconfigure $f -translation binary
# \x81 is an incomplete byte sequence in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none \
-translation lf -profile strict -blocking 0
} -body {
gets $f
# only the 2nd gets returns the error
gets $f
} -cleanup {
close $f
removeFile io-75.6.4
} -match glob -returnCodes 1 -result {error reading "file*":\
invalid or incomplete multibyte or wide character}
test io-75.7.gets {
invalid utf-8 encoding gets is not ignored (-profile strict)
} -setup {
set fn [makeFile {} io-75.7]
set f [open $fn w+]
fconfigure $f -encoding binary
# \x81 is invalid in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf \
-profile strict
} -body {
list [catch {gets $f} msg] $msg
} -cleanup {
close $f
removeFile io-75.7
unset msg f fn
} -match glob -result {1 {error reading "file*":\
invalid or incomplete multibyte or wide character}}
test io-75.7.read {
invalid utf-8 encoding read is not ignored (-profile strict)
} -setup {
set fn [makeFile {} io-75.7]
set f [open $fn w+]
fconfigure $f -translation binary
# \x81 is invalid in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -translation lf \
-profile strict
} -body {
list [catch {read $f} msg data] $msg [dict get $data -result read]
} -cleanup {
close $f
removeFile io-75.7
unset msg data f fn
} -match glob -result {1 {error reading "file*":\
invalid or incomplete multibyte or wide character} A}
test {io-75.8 {invalid input before eof}} {invalid utf-8 before eof (-profile strict)} -setup {
set hd {}
set fn [makeFile {} io-75.7]
set f [open $fn w+]
fconfigure $f -encoding binary
# \xA1 is invalid in utf-8. -eofchar is not detected, because it comes later.
puts -nonewline $f A\xA1\x1A
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \
-translation lf -profile strict
} -body {
set status [catch {read $f} cres copts]
if {[dict exists $copts -result read]} {
set d [dict get $copts -result read]
} else {
set d {}
}
binary scan $d H* hd
lappend hd [eof $f]
lappend hd $status
lappend hd $cres
fconfigure $f -encoding iso8859-1
lappend hd [read $f];# We changed encoding, so now we can read the \xA1
close $f
set hd
} -cleanup {
removeFile io-75.7
} -match glob -result {41 0 1 {error reading "file*":\
invalid or incomplete multibyte or wide character} ¡}
test {io-75.8 {incomplete input after eof}} {
incomplete utf-8 char after eof char is not an error (-profile strict)
} -setup {
set hd {}
set fn [makeFile {} io-75.8]
set f [open $fn w+]
fconfigure $f -translation binary
# \x81 is invalid in utf-8, but since the eof character \x1A comes first,
# -eofchar takes precedence.
puts -nonewline $f A\x1A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \
-translation lf -profile strict
} -body {
set d [read $f]
binary scan $d H* hd
lappend hd [eof $f]
# there should be no error on additional reads
lappend hd [read $f]
set hd
} -cleanup {
close $f
removeFile io-75.8
unset f d hd
} -result {41 1 {}}
test {io-75.8 {invalid input after eof}} {
invalid utf-8 after eof char is not an error (-profile strict)
} -setup {
set res {}
set fn [makeFile {} io-75.8]
set f [open $fn w+]
fconfigure $f -encoding binary
# \xc0\x80 is invalid utf-8 data, but because the eof character \x1A
# appears first, it's not an error.
puts -nonewline $f A\x1a\xc0\x80
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \
-translation lf -profile strict
} -body {
set d [read $f]
foreach char [split $d {}] {
lappend res [format %x [scan $char %c]]
}
lappend res [eof $f]
# there should be no error on additional reads
lappend res [read $f]
close $f
set res
} -cleanup {
removeFile io-75.8
} -result {41 1 {}}
test {io-75.8 {invalid input before eof}} {
invalid utf-8 encoding eof handling (-profile strict)
} -setup {
set fn [makeFile {} io-75.8]
set f [open $fn w+]
# This also configures the channel encoding profile as strict.
fconfigure $f -translation binary
# \x81 is invalid in utf-8. -eofchar is not detected, because it comes later.
puts -nonewline $f A\x81\x81\x1A
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \
-translation lf -profile strict
} -body {
set res [list [catch {read $f} msg data] [eof $f]]
if {[dict exists $data -result read]} {
lappend res [dict get $data -result read]
} else {
lappend res {}
}
chan configure $f -encoding iso8859-1
lappend res [read $f 1]
chan configure $f -encoding utf-8
lappend res [catch {read $f 1} msg data] $msg
if {[dict exists $data -result read]} {
lappend res [dict get $data -result read]
} else {
lappend res {}
}
return $res
} -cleanup {
close $f
removeFile io-75.8
unset res msg data fn f
} -match glob -result "1 0 A \x81 1 {error reading \"*\":\
invalid or incomplete multibyte or wide character} {}"
test io-strict-multibyte-eof {
incomplete utf-8 sequence immediately prior to eof character
See issue 25cdcb7e8fb381fb
} -setup {
set chan [file tempfile];
fconfigure $chan -translation binary
puts -nonewline $chan \x81\x1A
flush $chan
seek $chan 0
chan configure $chan -encoding utf-8 -profile strict
} -body {
list [catch {read $chan 1} msg data] $msg [if {
[dict exists $data -result read]
} {
dict get $data -result read
} else {
lindex {}
}
]
} -cleanup {
close $chan
unset msg chan data
} -match glob -result {1 {error reading "*":\
invalid or incomplete multibyte or wide character} {}}
test io-75.9 {unrepresentable character write throws error in strict profile} -setup {
set fn [makeFile {} io-75.9]
set f [open $fn w+]
fconfigure $f -encoding iso8859-1 -profile strict
} -body {
catch {puts -nonewline $f "A\u2022"} msg
flush $f
seek $f 0
list [read $f] $msg
} -cleanup {
close $f
removeFile io-75.9
unset f
} -match glob -result [list {A} {error writing "*":\
invalid or incomplete multibyte or wide character}]
apply [list {} {
set template {
test {io-75.10 ${mode}} {
incomplete multibyte encoding read is an error
} -setup {
set res {}
set fn [makeFile {} io-75.10]
set f [open $fn w+]
fconfigure $f -encoding binary
puts -nonewline $f A\xC0
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none {*}${option}
} -body {
set status [catch {read $f} cres copts]
set d [dict get $copts -result read]
close $f
binary scan $d H* hd
lappend res $hd
lappend res $status
lappend res $cres
return $res
} -cleanup {
removeFile io-75.10
} -match glob -result {41 1 {error reading "file*":\
invalid or incomplete multibyte or wide character}}
}
# the default encoding mode is not currently strict
#foreach mode {default strict} option {{} {-encodingstrict 1}}
foreach mode {{profile strict}} option {{-profile strict}} {
set test [string map [
list {${mode}} [list $mode] {${option}} [list $option]] $template]
uplevel $test
}
} [namespace current]]
test {io-75.10 {profile tcl8}} {
incomplete multibyte encoding read is not ignored because "binary" sets
profile to strict
} -setup {
set res {}
set fn [makeFile {} io-75.10]
set f [open $fn w+]
fconfigure $f -translation binary
puts -nonewline $f A\xC0
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none
} -body {
catch {read $f} errmsg
lappend res $errmsg
seek $f 0
chan configure $f -profile tcl8
set d [read $f]
binary scan $d H* hd
lappend res $hd
return $res
} -cleanup {
close $f
removeFile io-75.10
unset result
} -match glob -result {{error reading "file*":\
invalid or incomplete multibyte or wide character} 41c0}
# The current result returns the orphan byte as byte.
# This may be expected due to special utf-8 handling.
# As utf-8 has a special treatment in multi-byte decoding, also test another
# one.
test io-75.11 {shiftjis encoding error read results in error (strict profile)} -setup {
set fn [makeFile {} io-75.11]
set f [open $fn w+]
fconfigure $f -translation binary
# In shiftjis, \x81 starts a two-byte sequence.
# But 2nd byte \xFF is not allowed
puts -nonewline $f A\x81\xFFA
flush $f
seek $f 0
fconfigure $f -encoding shiftjis -blocking 0 -translation lf \
-profile strict
} -body {
set d [read $f]
binary scan $d H* hd
lappend hd [catch {set d [read $f]} msg data] $msg [
dict exists $data -result read]
} -cleanup {
close $f
removeFile io-75.11
unset d hd msg data f
} -match glob -result {41 1 {error reading "file*":\
invalid or incomplete multibyte or wide character} 0}
apply [list {} {
set template {
test {io-75.12 ${mode}} {
invalid utf-8 encoding read returns an error
} -setup {
set res {}
set fn [makeFile {} io-75.12]
set f [open $fn w+]
fconfigure $f -encoding binary
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar {} \
-translation lf {*}${option}
} -body {
set status [catch {read $f} cres copts]
set d [dict get $copts -result read]
close $f
binary scan $d H* hd
lappend res $hd $status $cres
return $res
} -cleanup {
removeFile io-75.12
} -match glob -result {41 1 {error reading "file*":\
invalid or incomplete multibyte or wide character}}
}
# the default encoding mod is not currently strict
#foreach mode {default strict} option {{} {-encodingstrict 1}}
foreach mode {{profile strict}} option {{-profile strict}} {
set test [string map [
list {${mode}} [list $mode] {${option}} [list $option]] $template]
uplevel $test
}
} [namespace current]]
test {io-75.12 {profile tcl8}} {
invalid utf-8 encoding read, is not ignored because setting the encoding to
"binary" also sets the profile to strict
} -setup {
set res {}
set fn [makeFile {} io-75.12]
set f [open $fn w+]
fconfigure $f -translation binary
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -translation lf
} -body {
catch {read $f} errmsg
lappend res $errmsg
chan configure $f -profile tcl8
seek $f 0
set d [read $f]
binary scan $d H* hd
lappend res $hd
return $res
} -cleanup {
close $f
removeFile io-75.12
unset res
} -match glob -result {{error reading "file*":\
invalid or incomplete multibyte or wide character} 4181}
test io-75.13 {
In blocking mode [read] produces an error and leaves the data succesfully
read so far in the return options dictionary.
} -setup {
set fn [makeFile {} io-75.13]
set f [open $fn w+]
fconfigure $f -encoding binary
# \x81 is invalid in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -eofchar "" -translation lf -profile strict
} -body {
set status [catch {read $f} cres copts]
set d [dict get $copts -result read]
binary scan $d H* hd
lappend hd $status
lappend hd $cres
} -cleanup {
close $f
removeFile io-75.13
} -match glob -result {41 1 {error reading "file*":\
invalid or incomplete multibyte or wide character}}
test io-75.13.nonblocking {
In nonblocking mode when there is an encoding error the data that has been
successfully read so far is returned first and then the error is returned
on the next call to [read].
} -setup {
set fn [makeFile {} io-75.13]
set f [open $fn w+]
fconfigure $f -translation binary
# \x81 is invalid in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -blocking 0 -translation lf \
-profile strict
} -body {
set d [read $f]
binary scan $d H* hd
lappend hd [catch {read $f} msg data] $msg [dict exists $data -result read]
} -cleanup {
close $f
removeFile io-75.13
unset d hd msg data f fn
} -match glob -result {41 1 {error reading "file*":\
invalid or incomplete multibyte or wide character} 0}
test io-75.14 {
[gets] succesfully returns lines prior to error
invalid utf-8 encoding [gets] continues in non-strict mode after error
} -setup {
set chan [file tempfile]
fconfigure $chan -translation binary
# \xC0\n is an invalid utf-8 sequence
puts -nonewline $chan a\nb\nc\xC0\nd\n
flush $chan
seek $chan 0
fconfigure $chan -encoding utf-8 -buffering none \
-translation auto -profile strict
} -body {
set res [gets $chan]
lappend res [gets $chan]
lappend res [catch {gets $chan} msg data] $msg [
if {[dict exists $data -result read]} {
dict get $data -result read
} else {
lindex {}
}
]
chan configure $chan -profile tcl8
lappend res [gets $chan]
lappend res [gets $chan]
return $res
} -cleanup {
close $chan
unset chan res msg data
} -match glob -result {a b 1 {error reading "*":\
invalid or incomplete multibyte or wide character} {} cÀ d}
test io-75.15 {
invalid utf-8 encoding strict
gets does not hang
gets succeeds for the first two lines
} -setup {
set res {}
set chan [file tempfile]
fconfigure $chan -translation binary
# \xC0\x40 is an invalid utf-8 sequence
puts $chan hello\nAB\nCD\xC0\x40EF\nGHI
seek $chan 0
} -body {
#Now try to read it with [gets]
fconfigure $chan -encoding utf-8 -profile strict
lappend res [gets $chan]
lappend res [gets $chan]
lappend res [catch {gets $chan} msg data] $msg [dict exists $data -result read]
lappend res [catch {gets $chan} msg data] $msg [dict exists $data -result read]
chan configure $chan -translation binary
set data [read $chan 4]
foreach char [split $data {}] {
scan $char %c ord
lappend res [format %x $ord]
}
fconfigure $chan -encoding utf-8 -profile strict -translation auto
lappend res [gets $chan]
lappend res [gets $chan]
return $res
} -cleanup {
close $chan
unset chan res msg data
} -match glob -result {hello AB 1 {error reading "*": invalid or incomplete multibyte or wide character}\
0 1 {error reading "*": invalid or incomplete multibyte or wide character} 0 43 44 c0 40 EF GHI}
test io-75.14 {invalid utf-8 encoding [gets] continues in non-strict mode after error} -setup {
set res {}
set fn [makeFile {} io-75.14]
set f [open $fn w+]
fconfigure $f -encoding binary
# \xc0 is invalid in utf-8
puts -nonewline $f a\nb\xc0\nc\n
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf -profile strict
} -body {
lappend res [gets $f]
set status [catch {gets $f} cres copts]
lappend res $status $cres
chan configure $f -profile tcl8
lappend res [gets $f]
lappend res [gets $f]
close $f
return $res
} -cleanup {
removeFile io-75.14
} -match glob -result {a 1 {error reading "file*":\
invalid or incomplete multibyte or wide character} bÀ c}
test io-75.15 {invalid utf-8 encoding strict gets should not hang} -setup {
set res {}
set fn [makeFile {} io-75.15]
set chan [open $fn w+]
fconfigure $chan -encoding binary
# This is not valid UTF-8
puts $chan hello\nAB\xc0\x40CD\nEFG
close $chan
} -body {
#Now try to read it with [gets]
set chan [open $fn]
fconfigure $chan -encoding utf-8 -profile strict
lappend res [gets $chan]
set status [catch {gets $chan} cres copts]
lappend res $status $cres
set status [catch {gets $chan} cres copts]
lappend res $status $cres
lappend res [
if {[dict exists $copts -result read]} {
dict get $copts -result read
} else {
lindex {}
}
]
chan configure $chan -encoding binary
foreach char [split [read $chan 2] {}] {
lappend res [format %x [scan $char %c]]
}
return $res
} -cleanup {
close $chan
removeFile io-75.15
} -match glob -result {hello 1 {error reading "file*":\
invalid or incomplete multibyte or wide character} 1 {error reading "file*":\
invalid or incomplete multibyte or wide character} {} 41 42}
# ### ### ### ######### ######### #########
test io-76.0 {channel modes} -setup {
set datafile [makeFile {some characters} dummy]
set f [open $datafile r]
} -constraints testchannel -body {
testchannel mode $f
} -cleanup {
close $f
removeFile dummy
} -result {read {}}
test io-76.1 {channel modes} -setup {
set datafile [makeFile {some characters} dummy]
set f [open $datafile w]
} -constraints testchannel -body {
testchannel mode $f
} -cleanup {
close $f
removeFile dummy
} -result {{} write}
test io-76.2 {channel modes} -setup {
set datafile [makeFile {some characters} dummy]
set f [open $datafile r+]
} -constraints testchannel -body {
testchannel mode $f
} -cleanup {
close $f
removeFile dummy
} -result {read write}
test io-76.3 {channel mode dropping} -setup {
set datafile [makeFile {some characters} dummy]
set f [open $datafile r]
} -constraints testchannel -body {
testchannel mremove-wr $f
list [testchannel mode $f] [testchannel maxmode $f]
} -cleanup {
close $f
removeFile dummy
} -result {{read {}} {read {}}}
test io-76.4 {channel mode dropping} -setup {
set datafile [makeFile {some characters} dummy]
set f [open $datafile r]
} -constraints testchannel -body {
testchannel mremove-rd $f
} -returnCodes error -cleanup {
close $f
removeFile dummy
} -match glob -result {Tcl_RemoveChannelMode error:\
Bad mode, would make channel inacessible. Channel: "*"}
test io-76.5 {channel mode dropping} -setup {
set datafile [makeFile {some characters} dummy]
set f [open $datafile w]
} -constraints testchannel -body {
testchannel mremove-rd $f
list [testchannel mode $f] [testchannel maxmode $f]
} -cleanup {
close $f
removeFile dummy
} -result {{{} write} {{} write}}
test io-76.6 {channel mode dropping} -setup {
set datafile [makeFile {some characters} dummy]
set f [open $datafile w]
} -constraints testchannel -body {
testchannel mremove-wr $f
} -returnCodes error -cleanup {
close $f
removeFile dummy
} -match glob -result {Tcl_RemoveChannelMode error:\
Bad mode, would make channel inacessible. Channel: "*"}
test io-76.7 {channel mode dropping} -setup {
set datafile [makeFile {some characters} dummy]
set f [open $datafile r+]
} -constraints testchannel -body {
testchannel mremove-rd $f
list [testchannel mode $f] [testchannel maxmode $f]
} -cleanup {
close $f
removeFile dummy
} -result {{{} write} {read write}}
test io-76.8 {channel mode dropping} -setup {
set datafile [makeFile {some characters} dummy]
set f [open $datafile r+]
} -constraints testchannel -body {
testchannel mremove-wr $f
list [testchannel mode $f] [testchannel maxmode $f]
} -cleanup {
close $f
removeFile dummy
} -result {{read {}} {read write}}
test io-76.9 {channel mode dropping} -setup {
set datafile [makeFile {some characters} dummy]
set f [open $datafile r+]
} -constraints testchannel -body {
testchannel mremove-wr $f
testchannel mremove-rd $f
} -returnCodes error -cleanup {
close $f
removeFile dummy
} -match glob -result {Tcl_RemoveChannelMode error:\
Bad mode, would make channel inacessible. Channel: "*"}
test io-76.10 {channel mode dropping} -setup {
set datafile [makeFile {some characters} dummy]
set f [open $datafile r+]
} -constraints testchannel -body {
testchannel mremove-rd $f
testchannel mremove-wr $f
} -returnCodes error -cleanup {
close $f
removeFile dummy
} -match glob -result {Tcl_RemoveChannelMode error:\
Bad mode, would make channel inacessible. Channel: "*"}
# cleanup
foreach file [list fooBar longfile script2 output test1 pipe my_script \
test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] {
removeFile $file
}
cleanupTests
}
namespace delete ::tcl::test::io
return