Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Merge trunk |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | apn-icu |
| Files: | files | file ages | folders |
| SHA3-256: |
485c9811af3e753c326c032a48cbd14d |
| User & Date: | apnadkarni 2024-06-26 03:14:37 |
Context
|
2024-06-27
| ||
| 06:32 | Add tcl::unsupported::icu command check-in: 45b7ed88d0 user: apnadkarni tags: trunk, main | |
|
2024-06-26
| ||
| 03:14 | Merge trunk Closed-Leaf check-in: 485c9811af user: apnadkarni tags: apn-icu | |
|
2024-06-24
| ||
| 12:06 | Eliminate "-encoding binary" in all test-cases check-in: bf368d23e8 user: jan.nijtmans tags: trunk, main | |
|
2024-06-21
| ||
| 10:52 | Fix test constraint check-in: 4aa775e938 user: apnadkarni tags: apn-icu | |
Changes
Changes to doc/chan.n.
| ︙ | ︙ | |||
875 876 877 878 879 880 881 |
set data [chan read $chan]
chan puts "[string length $data] $data"
if {[chan eof $chan]} {
chan event $chan readable {}
}
}
| | | 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 |
set data [chan read $chan]
chan puts "[string length $data] $data"
if {[chan eof $chan]} {
chan event $chan readable {}
}
}
chan configure $chan -blocking 0 -translation binary
\fBchan event\fR $chan readable [list GetData $chan]
.CE
.PP
The next example is similar but uses \fBchan gets\fR to read
line-oriented data.
.PP
.CS
|
| ︙ | ︙ | |||
1034 1035 1036 1037 1038 1039 1040 |
% set d
-code 1 -level 0
-errorstack {INNER {invokeStk1 gets file384b6a8}}
-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}
-errorinfo {...} -errorline 1
% chan tell $f
0
| | | 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 |
% set d
-code 1 -level 0
-errorstack {INNER {invokeStk1 gets file384b6a8}}
-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}
-errorinfo {...} -errorline 1
% chan tell $f
0
% chan configure $f -translation binary
% chan gets $f
AÃB
.CE
.PP
The following example is similar to the above but demonstrates recovery after a
blocking read. The successfully decoded data "A" is returned in the error options
dictionary key \fB\-data\fR. The file position is advanced on the encoding error
|
| ︙ | ︙ | |||
1058 1059 1060 1061 1062 1063 1064 |
% set d
-data A -code 1 -level 0
-errorstack {INNER {invokeStk1 read file35a65a0}}
-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}
-errorinfo {...} -errorline 1
% chan tell $f
1
| | | 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 |
% set d
-data A -code 1 -level 0
-errorstack {INNER {invokeStk1 read file35a65a0}}
-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}
-errorinfo {...} -errorline 1
% chan tell $f
1
% chan configure $f -translation binary
% chan read $f
ÃB
% chan close $f
.CE
.PP
Finally the same example, but this time with a non-blocking channel.
.PP
|
| ︙ | ︙ |
Changes to doc/string.n.
| ︙ | ︙ | |||
146 147 148 149 150 151 152 | .IP \fBdigit\fR 12 Any Unicode digit character. Note that this includes characters outside of the [0\-9] range. .IP \fBdouble\fR 12 Any of the forms allowed to \fBTcl_GetDoubleFromObj\fR. .IP \fBentier\fR 12 . | | < < | | | | 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 | .IP \fBdigit\fR 12 Any Unicode digit character. Note that this includes characters outside of the [0\-9] range. .IP \fBdouble\fR 12 Any of the forms allowed to \fBTcl_GetDoubleFromObj\fR. .IP \fBentier\fR 12 . Synonym for \fBinteger\fR. .IP \fBfalse\fR 12 Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is false. .IP \fBgraph\fR 12 Any Unicode printing character, except space. .IP \fBinteger\fR 12 Any of the valid string formats for an integer value of arbitrary size in Tcl, with optional surrounding whitespace. The formats accepted are exactly those accepted by the C routine \fBTcl_GetBignumFromObj\fR. .IP \fBlist\fR 12 Any proper list structure, with optional surrounding whitespace. In case of improper list structure, 0 is returned and the \fIvarname\fR will contain the index of the .QW element where the list parsing fails, or \-1 if this cannot be determined. .IP \fBlower\fR 12 |
| ︙ | ︙ |
Changes to generic/tclIO.c.
| ︙ | ︙ | |||
339 340 341 342 343 344 345 |
FreeChannelInternalRep, /* freeIntRepProc */
DupChannelInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
TCL_OBJTYPE_V0
};
| < < < | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
FreeChannelInternalRep, /* freeIntRepProc */
DupChannelInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
TCL_OBJTYPE_V0
};
#define ChanSetInternalRep(objPtr, resPtr) \
do { \
Tcl_ObjInternalRep ir; \
(resPtr)->refCount++; \
ir.twoPtrValue.ptr1 = (resPtr); \
ir.twoPtrValue.ptr2 = NULL; \
Tcl_StoreInternalRep((objPtr), &chanObjType, &ir); \
|
| ︙ | ︙ | |||
1662 1663 1664 1665 1666 1667 1668 |
}
statePtr->channelName = tmp;
statePtr->flags = mask;
statePtr->maxPerms = mask; /* Save max privileges for close callback */
/*
* Set the channel to system default encoding.
| < < < < < < | 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 |
}
statePtr->channelName = tmp;
statePtr->flags = mask;
statePtr->maxPerms = mask; /* Save max privileges for close callback */
/*
* Set the channel to system default encoding.
*/
name = Tcl_GetEncodingName(NULL);
statePtr->encoding = Tcl_GetEncoding(NULL, name);
statePtr->inputEncodingState = NULL;
statePtr->inputEncodingFlags = TCL_ENCODING_START;
statePtr->outputEncodingState = NULL;
|
| ︙ | ︙ |
Changes to tests-perf/chan.perf.tcl.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 |
namespace eval ::tclTestPerf-Chan {
namespace path {::tclTestPerf}
proc _get_test_chan {{bufSize 4096}} {
lassign [chan pipe] ch wch;
| | | | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
namespace eval ::tclTestPerf-Chan {
namespace path {::tclTestPerf}
proc _get_test_chan {{bufSize 4096}} {
lassign [chan pipe] ch wch;
fconfigure $ch -translation lf -encoding utf-8 -buffersize $bufSize -buffering full
fconfigure $wch -translation lf -encoding utf-8 -buffersize $bufSize -buffering full
exec [info nameofexecutable] -- $bufSize >@$wch << {
set bufSize [lindex $::argv end]
fconfigure stdout -translation lf -encoding utf-8 -buffersize $bufSize -buffering full
set buf [string repeat test 1000]; # 4K
# write ~ 10*1M + 10*2M + 10*10M + 1*20M:
set i 0; while {$i < int((10*1e6 + 10*2e6 + 10*10e6 + 1*20e6)/4e3)} {
#puts -nonewline stdout $i\t
puts stdout $buf
#flush stdout; # don't flush to use full buffer
incr i
|
| ︙ | ︙ |
Changes to tests/chan.test.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 |
chan configure stdout -eofchar [list \x27 {}]
} -result {}
test chan-4.5 {chan command: check valid inValue, invalid outValue} -body {
chan configure stdout -eofchar [list \x27 \x80]
} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character}
test chan-4.6 {chan command: check no inValue, valid outValue} -body {
chan configure stdout -eofchar [list {} \x27]
| | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
chan configure stdout -eofchar [list \x27 {}]
} -result {}
test chan-4.5 {chan command: check valid inValue, invalid outValue} -body {
chan configure stdout -eofchar [list \x27 \x80]
} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character}
test chan-4.6 {chan command: check no inValue, valid outValue} -body {
chan configure stdout -eofchar [list {} \x27]
} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character}
test chan-5.1 {chan command: copy subcommand} -body {
chan copy foo
} -returnCodes error -result "wrong # args: should be \"chan copy input output ?-size size? ?-command callback?\""
test chan-6.1 {chan command: eof subcommand} -body {
chan eof foo bar
|
| ︙ | ︙ |
Changes to tests/chanio.test.
| ︙ | ︙ | |||
65 66 67 68 69 70 71 |
testConstraint makeFileInHome [expr {![file exists $::env(HOME)/_test_] && [file writable $::env(HOME)]}]
# set up a long data file for some of the following tests
set path(longfile) [makeFile {} longfile]
set f [open $path(longfile) w]
| | | | | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
testConstraint makeFileInHome [expr {![file exists $::env(HOME)/_test_] && [file writable $::env(HOME)]}]
# set up a long data file for some of the following tests
set path(longfile) [makeFile {} longfile]
set f [open $path(longfile) w]
chan configure $f -translation lf
for { set i 0 } { $i < 100 } { incr i} {
chan puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef
\#123456789abcdef01
\#"
}
chan close $f
set path(cat) [makeFile {
set f stdin
if {$argv != ""} {
set f [open [lindex $argv 0]]
}
chan configure $f -translation binary -blocking 0 -eofchar \x1A
chan configure stdout -translation binary -buffering none
chan event $f readable "foo $f"
proc foo {f} {
set x [chan read $f]
catch {chan puts -nonewline $x}
if {[chan eof $f]} {
chan close $f
exit 0
|
| ︙ | ︙ | |||
113 114 115 116 117 118 119 |
test chan-io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} {
# no test, need to cause an async error.
} {}
set path(test1) [makeFile {} test1]
test chan-io-1.6 {Tcl_WriteChars: WriteBytes} {
set f [open $path(test1) w]
| | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
test chan-io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} {
# no test, need to cause an async error.
} {}
set path(test1) [makeFile {} test1]
test chan-io-1.6 {Tcl_WriteChars: WriteBytes} {
set f [open $path(test1) w]
chan configure $f -translation binary
chan puts -nonewline $f "a\x4D\x00"
chan close $f
contents $path(test1)
} aM\x00
test chan-io-1.7 {Tcl_WriteChars: WriteChars} {
set f [open $path(test1) w]
chan configure $f -encoding shiftjis
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 |
chan close $f
lappend sizes [file size $path(test2)]
} {19 19 19 19 19}
test chan-io-2.1 {WriteBytes} {
# loop until all bytes are written
set f [open $path(test1) w]
| | | | | < | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 |
chan close $f
lappend sizes [file size $path(test2)]
} {19 19 19 19 19}
test chan-io-2.1 {WriteBytes} {
# loop until all bytes are written
set f [open $path(test1) w]
chan configure $f -translation binary -buffersize 16 -translation crlf
chan puts $f "abcdefghijklmnopqrstuvwxyz"
chan close $f
contents $path(test1)
} "abcdefghijklmnopqrstuvwxyz\r\n"
test chan-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]
chan configure $f -translation binary -buffersize 16 -translation crlf
chan puts -nonewline $f "123456789012345\n12"
set x [list [contents $path(test1)]]
chan close $f
lappend x [contents $path(test1)]
} [list "123456789012345\r" "123456789012345\r\n12"]
test chan-io-2.3 {WriteBytes: flush on line} -body {
# Tcl "line" buffering has weird behavior: if current buffer contains a
# \n, entire buffer gets flushed. Logical behavior would be to flush only
# up to the \n.
set f [open $path(test1) w]
chan configure $f -translation binary -buffering line -translation crlf
chan puts -nonewline $f "\n12"
contents $path(test1)
} -cleanup {
chan close $f
} -result "\r\n12"
test chan-io-2.4 {WriteBytes: reset sawLF after each buffer} {
set f [open $path(test1) w]
chan configure $f -translation binary -buffering line -buffersize 16
chan puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz"
set x [list [contents $path(test1)]]
chan close $f
lappend x [contents $path(test1)]
} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]
test chan-io-3.1 {WriteChars: compatibility with WriteBytes} {
|
| ︙ | ︙ | |||
365 366 367 368 369 370 371 |
chan puts -nonewline $f "12345678901\n456789012345678901234"
chan close $f
set x [contents $path(test1)]
} "12345678901\r\n456789012345678901234"
test chan-io-5.1 {CheckFlush: not full} {
set f [open $path(test1) w]
| < | 364 365 366 367 368 369 370 371 372 373 374 375 376 377 |
chan puts -nonewline $f "12345678901\n456789012345678901234"
chan close $f
set x [contents $path(test1)]
} "12345678901\r\n456789012345678901234"
test chan-io-5.1 {CheckFlush: not full} {
set f [open $path(test1) w]
chan puts -nonewline $f "12345678901234567890"
set x [list [contents $path(test1)]]
chan close $f
lappend x [contents $path(test1)]
} [list "" "12345678901234567890"]
test chan-io-5.2 {CheckFlush: full} {
set f [open $path(test1) w]
|
| ︙ | ︙ | |||
1077 1078 1079 1080 1081 1082 1083 |
chan gets $f
} -cleanup {
chan close $f
} -result "1234567890123０１２３４"
test chan-io-7.2 {FilterInputBytes: split up character in middle of buffer} -body {
# (bufPtr->nextAdded < bufPtr->bufLength)
set f [open $path(test1) w]
| | | | | | 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 |
chan gets $f
} -cleanup {
chan close $f
} -result "1234567890123０１２３４"
test chan-io-7.2 {FilterInputBytes: split up character in middle of buffer} -body {
# (bufPtr->nextAdded < bufPtr->bufLength)
set f [open $path(test1) w]
chan configure $f -translation binary
chan puts -nonewline $f "1234567890\n123\x82\x4F\x82\x50\x82"
chan close $f
set f [open $path(test1)]
chan configure $f -encoding shiftjis
list [chan gets $f line] $line [chan eof $f]
} -cleanup {
chan close $f
} -result {10 1234567890 0}
test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup {
set x ""
} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation binary
chan puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82"
chan close $f
set f [open $path(test1)]
chan configure $f -encoding shiftjis -profile tcl8
lappend x [chan gets $f line] $line
lappend x [chan tell $f] [testchannel inputbuffered $f] [chan eof $f]
lappend x [chan gets $f line] $line
} -cleanup {
chan close $f
} -result [list 16 "1234567890123０１\x82" 18 0 1 -1 ""]
test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup {
variable x ""
} -constraints {stdio fileevent} -body {
set f [openpipe w+ $path(cat)]
chan configure $f -translation binary -buffering none
chan puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82"
chan configure $f -encoding shiftjis -blocking 0
chan event $f read [namespace code {
lappend x [chan gets $f line] $line [chan blocked $f]
}]
vwait [namespace which -variable x]
chan configure $f -translation binary -blocking 1
chan puts $f "\x51\x82\x52"
chan configure $f -encoding shiftjis
vwait [namespace which -variable x]
return $x
} -cleanup {
chan close $f
} -result [list -1 "" 1 17 "1234567890123０１２３" 0]
|
| ︙ | ︙ | |||
1174 1175 1176 1177 1178 1179 1180 |
test chan-io-8.4 {PeekAhead: cached data available in this buffer} -body {
# not (bytesLeft == 0)
set f [open $path(test1) w+]
chan configure $f -translation binary
chan puts $f "${a}\r\nabcdef"
chan close $f
set f [open $path(test1)]
| | | 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 |
test chan-io-8.4 {PeekAhead: cached data available in this buffer} -body {
# not (bytesLeft == 0)
set f [open $path(test1) w+]
chan configure $f -translation binary
chan puts $f "${a}\r\nabcdef"
chan close $f
set f [open $path(test1)]
chan configure $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.
chan gets $f
} -cleanup {
chan close $f
} -result $a
|
| ︙ | ︙ | |||
1279 1280 1281 1282 1283 1284 1285 |
test chan-io-11.1 {ReadBytes: want to read a lot} -body {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
chan puts -nonewline $f abcdefghijkl
chan close $f
set f [open $path(test1)]
| | | | | | 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 |
test chan-io-11.1 {ReadBytes: want to read a lot} -body {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
chan puts -nonewline $f abcdefghijkl
chan close $f
set f [open $path(test1)]
chan configure $f -translation binary
# here
chan read $f 1000
} -cleanup {
chan close $f
} -result {abcdefghijkl}
test chan-io-11.2 {ReadBytes: want to read all} -body {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
chan puts -nonewline $f abcdefghijkl
chan close $f
set f [open $path(test1)]
chan configure $f -translation binary
# here
chan read $f
} -cleanup {
chan close $f
} -result {abcdefghijkl}
test chan-io-11.3 {ReadBytes: allocate more space} -body {
# (toRead > length - offset - 1)
set f [open $path(test1) w]
chan puts -nonewline $f abcdefghijklmnopqrstuvwxyz
chan close $f
set f [open $path(test1)]
chan configure $f -buffersize 16 -translation binary
# here
chan read $f
} -cleanup {
chan close $f
} -result {abcdefghijklmnopqrstuvwxyz}
test chan-io-11.4 {ReadBytes: EOF char found} -body {
# (TranslateInputEOL() != 0)
set f [open $path(test1) w]
chan puts $f abcdefghijklmnopqrstuvwxyz
chan close $f
set f [open $path(test1)]
chan configure $f -translation binary -eofchar m
# here
list [chan read $f] [chan eof $f] [chan read $f] [chan eof $f]
} -cleanup {
chan close $f
} -result {abcdefghijkl 1 {} 1}
test chan-io-12.1 {ReadChars: want to read a lot} -body {
|
| ︙ | ︙ | |||
1361 1362 1363 1364 1365 1366 1367 |
chan close $f
} -result {abcdefghijklmnopqrstuvwxyz}
test chan-io-12.4 {ReadChars: split-up char} -setup {
variable x {}
} -constraints {stdio testchannel fileevent} -body {
# (srcRead == 0)
set f [openpipe w+ $path(cat)]
| | | | | 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 |
chan close $f
} -result {abcdefghijklmnopqrstuvwxyz}
test chan-io-12.4 {ReadChars: split-up char} -setup {
variable x {}
} -constraints {stdio testchannel fileevent} -body {
# (srcRead == 0)
set f [openpipe w+ $path(cat)]
chan configure $f -translation binary -buffering none -buffersize 16
chan puts -nonewline $f "123456789012345\x96"
chan configure $f -encoding shiftjis -blocking 0
chan event $f read [namespace code {
lappend x [chan read $f] [testchannel inputbuffered $f]
}]
chan configure $f -encoding shiftjis
vwait [namespace which -variable x]
chan configure $f -translation binary -blocking 1
chan puts -nonewline $f \x7B
after 500 ;# Give the cat process time to catch up
chan configure $f -encoding shiftjis -blocking 0
vwait [namespace which -variable x]
return $x
} -cleanup {
chan close $f
} -result [list "123456789012345" 1 本 0]
test chan-io-12.5 {ReadChars: chan events on partial characters} -setup {
variable x {}
} -constraints {stdio fileevent} -body {
set path(test1) [makeFile {
chan configure stdout -translation binary -buffering none
chan gets stdin; chan puts -nonewline \xE7
chan gets stdin; chan puts -nonewline \x89
chan gets stdin; chan puts -nonewline \xA6
} test1]
set f [openpipe r+ $path(test1)]
chan event $f readable [namespace code {
lappend x [chan read $f]
|
| ︙ | ︙ | |||
1949 1950 1951 1952 1953 1954 1955 |
chan close $f
} -result "file"
test chan-io-25.1 {Tcl_GetChannelHandle, input} -setup {
set l ""
} -constraints {testchannel} -body {
set f [open $path(test1) w]
| | | 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 |
chan close $f
} -result "file"
test chan-io-25.1 {Tcl_GetChannelHandle, input} -setup {
set l ""
} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f "1234567890\n098765432"
chan close $f
set f [open $path(test1) r]
chan gets $f
lappend l [testchannel inputbuffered $f]
lappend l [chan tell $f]
} -cleanup {
|
| ︙ | ︙ | |||
2001 2002 2003 2004 2005 2006 2007 |
chan close $f
} -result 0
test chan-io-27.2 {FlushChannel, some output buffered} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
| | | | | | | 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 |
chan close $f
} -result 0
test chan-io-27.2 {FlushChannel, some output buffered} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f hello
lappend l [file size $path(test1)]
chan flush $f
lappend l [file size $path(test1)]
chan close $f
lappend l [file size $path(test1)]
} -result {0 6 6}
test chan-io-27.3 {FlushChannel, implicit flush on chan close} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f hello
lappend l [file size $path(test1)]
chan close $f
lappend l [file size $path(test1)]
} -result {0 6}
test chan-io-27.4 {FlushChannel, implicit flush when buffer fills} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan configure $f -buffersize 60
lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
chan puts $f hello
}
lappend l [file size $path(test1)]
chan flush $f
lappend l [file size $path(test1)]
} -cleanup {
chan close $f
} -result {0 60 72}
test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan close} -setup {
file delete $path(test1)
set l ""
} -constraints {unixOrWin} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffersize 60
lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
chan puts $f hello
}
lappend l [file size $path(test1)]
chan close $f
lappend l [file size $path(test1)]
} -result {0 60 72}
set path(pipe) [makeFile {} pipe]
set path(output) [makeFile {} output]
test chan-io-27.6 {FlushChannel, async flushing, async chan close} -setup {
file delete $path(pipe)
file delete $path(output)
} -constraints {stdio asyncPipeChan Close} -body {
set f [open $path(pipe) w]
chan puts $f "set f \[[list open $path(output) w]]"
chan puts $f {
chan configure $f -translation lf -buffering none
while {![chan eof stdin]} {
after 20
chan puts -nonewline $f [chan read stdin 1024]
}
chan close $f
}
chan close $f
|
| ︙ | ︙ | |||
2129 2130 2131 2132 2133 2134 2135 |
} -result abcdef
test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} -setup {
file delete $path(pipe)
file delete $path(output)
} -constraints {stdio asyncPipeChan Close nonPortable} -body {
set f [open $path(pipe) w]
chan puts $f {
| < < < < < | | 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 |
} -result abcdef
test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} -setup {
file delete $path(pipe)
file delete $path(output)
} -constraints {stdio asyncPipeChan Close nonPortable} -body {
set f [open $path(pipe) w]
chan puts $f {
set f [open $path(output) w]
chan configure $f -translation lf -buffering none
for {set x 0} {$x < 20} {incr x} {
after 20
chan puts -nonewline $f [chan read stdin 1024]
}
chan close $f
}
chan close $f
set x 01234567890123456789012345678901
for {set i 0} {$i < 11} {incr i} {
set x "$x$x"
}
set f [open $path(output) w]
chan close $f
set f [openpipe r+ $path(pipe)]
chan configure $f -blocking off
chan puts -nonewline $f $x
chan 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]
}
|
| ︙ | ︙ | |||
2267 2268 2269 2270 2271 2272 2273 |
test chan-io-29.1 {Tcl_WriteChars, channel not writable} -body {
chan puts stdin hello
} -returnCodes error -result {channel "stdin" wasn't opened for writing}
test chan-io-29.2 {Tcl_WriteChars, empty string} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
| < < | | | | | 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 |
test chan-io-29.1 {Tcl_WriteChars, channel not writable} -body {
chan puts stdin hello
} -returnCodes error -result {channel "stdin" wasn't opened for writing}
test chan-io-29.2 {Tcl_WriteChars, empty string} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan puts -nonewline $f ""
chan close $f
file size $path(test1)
} -result 0
test chan-io-29.3 {Tcl_WriteChars, nonempty string} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan puts -nonewline $f hello
chan close $f
file size $path(test1)
} -result 5
test chan-io-29.4 {Tcl_WriteChars, buffering in full buffering mode} -setup {
file delete $path(test1)
set l ""
} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffering full
chan puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
chan flush $f
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
} -cleanup {
chan close $f
} -result {6 0 0 6}
test chan-io-29.5 {Tcl_WriteChars, buffering in line buffering mode} -setup {
file delete $path(test1)
set l ""
} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffering line
chan puts -nonewline $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
chan puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
} -cleanup {
chan close $f
} -result {5 0 0 11}
test chan-io-29.6 {Tcl_WriteChars, buffering in no buffering mode} -setup {
file delete $path(test1)
set l ""
} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffering none
chan puts -nonewline $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
chan puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
} -cleanup {
chan close $f
} -result {0 5 0 11}
test chan-io-29.7 {Tcl_Flush, full buffering} -setup {
file delete $path(test1)
set l ""
} -constraints {testchannel} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffering full
chan puts -nonewline $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
chan puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
chan flush $f
|
| ︙ | ︙ | |||
2372 2373 2374 2375 2376 2377 2378 |
test chan-io-29.9 {Tcl_Flush, channel not writable} -body {
chan flush stdin
} -returnCodes error -result {channel "stdin" wasn't opened for writing}
test chan-io-29.10 {Tcl_WriteChars, looping and buffering} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
| | < | 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 |
test chan-io-29.9 {Tcl_Flush, channel not writable} -body {
chan flush stdin
} -returnCodes error -result {channel "stdin" wasn't opened for writing}
test chan-io-29.10 {Tcl_WriteChars, looping and buffering} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
set f2 [open $path(longfile) r]
for {set x 0} {$x < 10} {incr x} {
chan puts $f1 [chan gets $f2]
}
chan close $f2
chan close $f1
file size $path(test1)
} -result 387
test chan-io-29.11 {Tcl_WriteChars, no newline, implicit flush} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
set f2 [open $path(longfile) r]
for {set x 0} {$x < 10} {incr x} {
chan puts -nonewline $f1 [chan gets $f2]
}
chan close $f1
chan close $f2
file size $path(test1)
|
| ︙ | ︙ | |||
2519 2520 2521 2522 2523 2524 2525 |
} -cleanup {
chan close $f1
} -result {18 24 30}
test chan-io-29.19 {Explicit and implicit flushes} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
| | | | 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 |
} -cleanup {
chan close $f1
} -result {18 24 30}
test chan-io-29.19 {Explicit and implicit flushes} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
set x ""
chan puts $f1 hello
chan puts $f1 hello
chan puts $f1 hello
chan flush $f1
lappend x [file size $path(test1)]
chan puts $f1 hello
chan flush $f1
lappend x [file size $path(test1)]
chan puts $f1 hello
chan close $f1
lappend x [file size $path(test1)]
} -result {18 24 30}
test chan-io-29.20 {Implicit flush when buffer is full} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
for {set x 0} {$x < 100} {incr x} {
chan puts $f1 $line
}
set z ""
lappend z [file size $path(test1)]
for {set x 0} {$x < 100} {incr x} {
|
| ︙ | ︙ | |||
2678 2679 2680 2681 2682 2683 2684 |
}
string tolower $x
} -match glob -result {1 {error flushing "*": broken pipe} {posix epipe {broken pipe}}}
test chan-io-29.28 {Tcl_WriteChars, lf mode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
| | | | | 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 |
}
string tolower $x
} -match glob -result {1 {error flushing "*": broken pipe} {posix epipe {broken pipe}}}
test chan-io-29.28 {Tcl_WriteChars, lf mode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f hello\nthere\nand\nhere
chan flush $f
file size $path(test1)
} -cleanup {
chan close $f
} -result 21
test chan-io-29.29 {Tcl_WriteChars, cr mode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f hello\nthere\nand\nhere
chan close $f
file size $path(test1)
} -result 21
test chan-io-29.30 {Tcl_WriteChars, crlf mode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f hello\nthere\nand\nhere
chan close $f
file size $path(test1)
} -result 25
test chan-io-29.31 {Tcl_WriteChars, background flush} -setup {
file delete $path(pipe)
file delete $path(output)
|
| ︙ | ︙ | |||
3176 3177 3178 3179 3180 3181 3182 |
chan close $f
} -result {abc def 0 {} 1 {} 1}
test chan-io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
| | | | | | | | 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 |
chan close $f
} -result {abc def 0 {} 1 {} 1}
test chan-io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f [format "abc\ndef\n%cghi\nqrs" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation lf
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result "abc def 0 \x1Aghi 0 qrs 0 {} 1"
test chan-io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f [format "abc\ndef\n%cghi\nqrs" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation cr
set x [chan gets $f]
lappend l [string equal $x "abc\ndef\n\x1Aghi\nqrs\n"]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result {1 1 {} 1}
test chan-io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f [format "abc\ndef\n%cghi\nqrs" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf
set x [chan gets $f]
lappend l [string equal $x "abc\ndef\n\x1Aghi\nqrs\n"]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
} -cleanup {
chan close $f
|
| ︙ | ︙ | |||
3730 3731 3732 3733 3734 3735 3736 |
chan close $f
} -result {abc def 0 {} 1}
test chan-io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
| | | | | | | | 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 |
chan close $f
} -result {abc def 0 {} 1}
test chan-io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation lf
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result "abc def 0 \x1Aqrs 0 tuv 0 {} 1"
test chan-io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation cr
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result "abc def 0 \x1Aqrs 0 tuv 0 {} 1"
test chan-io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
|
| ︙ | ︙ | |||
3832 3833 3834 3835 3836 3837 3838 |
chan close $f
} -result {abc def 0 {} 1}
test chan-io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
| | | | | | 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 |
chan close $f
} -result {abc def 0 {} 1}
test chan-io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1A
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result {abc def 0 {} 1}
test chan-io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation cr -eofchar \x1A
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result {abc def 0 {} 1}
test chan-io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1A
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result {abc def 0 {} 1}
test chan-io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} -setup {
file delete $path(test1)
set l ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf -eofchar \x1A
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
|
| ︙ | ︙ | |||
4217 4218 4219 4220 4221 4222 4223 |
set x 24
chan gets $f x(0)
} -returnCodes error -cleanup {
chan close $f
} -result {can't set "x(0)": variable isn't array}
test chan-io-33.8 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
| | | | | 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 |
set x 24
chan gets $f x(0)
} -returnCodes error -cleanup {
chan close $f
} -result {can't set "x(0)": variable isn't array}
test chan-io-33.8 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
chan configure $f -translation lf
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 100} {incr y} {chan puts $f $x}
chan close $f
set f [open $path(test3) r]
chan configure $f -translation lf
for {set y 0} {$y < 100} {incr y} {chan gets $f}
chan close $f
set y
} 100
test chan-io-33.9 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
chan configure $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} {chan puts $f $x}
chan close $f
set f [open $path(test3) r]
chan configure $f -translation lf
for {set y 0} {$y < 200} {incr y} {chan gets $f}
chan close $f
set y
} 200
test chan-io-33.10 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
chan configure $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} {chan puts $f $x}
chan close $f
set f [open $path(test3) r]
chan configure $f -translation lf
for {set y 0} {$y < 300} {incr y} {chan gets $f}
|
| ︙ | ︙ | |||
4268 4269 4270 4271 4272 4273 4274 |
} -cleanup {
chan close $f1
} -result 0
test chan-io-34.2 {Tcl_Seek to offset from start} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
| | | | | | | | 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 |
} -cleanup {
chan close $f1
} -result 0
test chan-io-34.2 {Tcl_Seek to offset from start} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 10 start
chan tell $f1
} -cleanup {
chan close $f1
} -result 10
test chan-io-34.3 {Tcl_Seek to end of file} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 0 end
chan tell $f1
} -cleanup {
chan close $f1
} -result 54
test chan-io-34.4 {Tcl_Seek to offset from end of file} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 -10 end
chan tell $f1
} -cleanup {
chan close $f1
} -result 44
test chan-io-34.5 {Tcl_Seek to offset from current position} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 10 current
chan seek $f1 10 current
chan tell $f1
} -cleanup {
chan close $f1
} -result 20
test chan-io-34.6 {Tcl_Seek to offset from end of file} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 -10 end
list [chan tell $f1] [chan read $f1]
} -cleanup {
chan close $f1
} -result {44 {rstuvwxyz
}}
test chan-io-34.7 {Tcl_Seek to offset from end of file, then to current position} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 -10 end
set c1 [chan tell $f1]
set r1 [chan read $f1 5]
|
| ︙ | ︙ | |||
4364 4365 4366 4367 4368 4369 4370 |
} -returnCodes error -cleanup {
chan close $pipe
} -match glob -result {error during seek on "*": invalid argument}
test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} -setup {
file delete $path(test3)
} -body {
set f [open $path(test3) w]
| < | 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 |
} -returnCodes error -cleanup {
chan close $pipe
} -match glob -result {error during seek on "*": invalid argument}
test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} -setup {
file delete $path(test3)
} -body {
set f [open $path(test3) w]
chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
chan close $f
set f [open $path(test3) RDWR]
set x [chan read $f 1]
chan seek $f 3
lappend x [chan read $f 1]
chan seek $f 0 start
|
| ︙ | ︙ | |||
4412 4413 4414 4415 4416 4417 4418 |
chan seek $f 2
set x [chan gets $f]
chan close $f
list $x [viewFile test3]
} "zzy xyzzy"
test chan-io-34.12 {Tcl_Seek testing combination of write, seek back and read} {
set f [open $path(test3) w]
| | | | 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 |
chan seek $f 2
set x [chan gets $f]
chan close $f
list $x [viewFile test3]
} "zzy xyzzy"
test chan-io-34.12 {Tcl_Seek testing combination of write, seek back and read} {
set f [open $path(test3) w]
chan configure $f -translation lf
chan puts $f xyz\n123
chan close $f
set f [open $path(test3) a+]
chan configure $f -translation lf
chan puts $f xyzzy
chan flush $f
set x [chan tell $f]
chan seek $f -4 cur
set y [chan gets $f]
chan close $f
list $x [viewFile test3] $y
|
| ︙ | ︙ | |||
4439 4440 4441 4442 4443 4444 4445 |
} -cleanup {
chan close $f1
} -result 0
test chan-io-34.14 {Tcl_Tell after seek to end of file} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
| | | | 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 |
} -cleanup {
chan close $f1
} -result 0
test chan-io-34.14 {Tcl_Tell after seek to end of file} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 0 end
chan tell $f1
} -cleanup {
chan close $f1
} -result 54
test chan-io-34.15 {Tcl_Tell combined with seeking} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan puts $f1 "abcdefghijklmnopqrstuvwxyz"
chan close $f1
set f1 [open $path(test1) r]
chan seek $f1 10 start
set c1 [chan tell $f1]
chan seek $f1 10 current
|
| ︙ | ︙ | |||
4484 4485 4486 4487 4488 4489 4490 |
chan close $f1
set c
} -1
test chan-io-34.18 {Tcl_Tell combined with seeking and reading} -setup {
file delete $path(test2)
} -body {
set f [open $path(test2) w]
| | | | 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 |
chan close $f1
set c
} -1
test chan-io-34.18 {Tcl_Tell combined with seeking and reading} -setup {
file delete $path(test2)
} -body {
set f [open $path(test2) w]
chan configure $f -translation lf
chan puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n"
chan close $f
set f [open $path(test2)]
chan configure $f -translation lf
set x [chan tell $f]
chan read $f 3
lappend x [chan tell $f]
chan seek $f 2
lappend x [chan tell $f]
chan seek $f 10 current
lappend x [chan tell $f]
chan seek $f 0 end
lappend x [chan tell $f]
} -cleanup {
chan close $f
} -result {0 3 2 12 30}
test chan-io-34.19 {Tcl_Tell combined with opening in append mode} -body {
set f [open $path(test3) w]
chan configure $f -translation lf
chan puts $f "abcdefghijklmnopqrstuvwxyz"
chan puts $f "abcdefghijklmnopqrstuvwxyz"
chan close $f
set f [open $path(test3) a]
chan tell $f
} -cleanup {
chan close $f
|
| ︙ | ︙ | |||
4533 4534 4535 4536 4537 4538 4539 |
chan close $f
} -result {29 39 40 447}
test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} -setup {
file delete $path(test3)
set l ""
} -constraints {largefileSupport extensive} -body {
set f [open $path(test3) w]
| | | 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 |
chan close $f
} -result {29 39 40 447}
test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} -setup {
file delete $path(test3)
set l ""
} -constraints {largefileSupport extensive} -body {
set f [open $path(test3) w]
chan configure $f -translation binary
lappend l [chan tell $f]
chan puts -nonewline $f abcdef
lappend l [chan tell $f]
chan flush $f
lappend l [chan tell $f]
# 4GB offset!
chan seek $f 0x100000000
|
| ︙ | ︙ | |||
4730 4731 4732 4733 4734 4735 4736 |
} -cleanup {
chan close $f
} -result {10 8 1}
test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
| | | | | | | | 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 |
} -cleanup {
chan close $f
} -result {10 8 1}
test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f [format abc\ndef\n%cqrs\nuvw 26]
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1A
list $c [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
} -result {17 8 1}
test chan-io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f [format abc\ndef\n%cqrs\nuvw 26]
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation lf -eofchar \x1A
list $c [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
} -result {17 8 1}
test chan-io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f [format abc\ndef\n%cqrs\nuvw 26]
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1A
list $c [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
} -result {17 8 1}
test chan-io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation cr
chan puts $f [format abc\ndef\n%cqrs\nuvw 26]
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation cr -eofchar \x1A
list $c [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
} -result {17 8 1}
test chan-io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f [format abc\ndef\n%cqrs\nuvw 26]
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation auto -eofchar \x1A
list $c [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
} -result {21 8 1}
test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
chan puts $f [format abc\ndef\n%cqrs\nuvw 26]
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
chan configure $f -translation crlf -eofchar \x1A
list $c [string length [chan read $f]] [chan eof $f]
} -cleanup {
|
| ︙ | ︙ | |||
5074 5075 5076 5077 5078 5079 5080 |
chan close $f1
} -result {0 21}
test chan-io-39.8 {Tcl_SetChannelOption, different buffering options} -setup {
file delete $path(test1)
set l ""
} -body {
set f1 [open $path(test1) w]
| | | 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 |
chan close $f1
} -result {0 21}
test chan-io-39.8 {Tcl_SetChannelOption, different buffering options} -setup {
file delete $path(test1)
set l ""
} -body {
set f1 [open $path(test1) w]
chan configure $f1 -translation lf -buffering none
chan puts -nonewline $f1 hello
lappend l [file size $path(test1)]
chan puts -nonewline $f1 hello
lappend l [file size $path(test1)]
chan configure $f1 -buffering full
chan puts -nonewline $f1 hello
lappend l [file size $path(test1)]
|
| ︙ | ︙ | |||
5174 5175 5176 5177 5178 5179 5180 |
} -cleanup {
chan close $f
} -result 40000
test chan-io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
| | | | | | 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 |
} -cleanup {
chan close $f
} -result 40000
test chan-io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation binary
chan puts -nonewline $f \xE7\x89\xA6
chan close $f
set f [open $path(test1) r]
chan configure $f -encoding utf-8
chan read $f
} -cleanup {
chan close $f
} -result 牦
test chan-io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation binary
chan puts -nonewline $f \xE7\x89\xA6
chan close $f
set f [open $path(test1) r]
chan configure $f -encoding utf-8
chan read $f
} -cleanup {
chan close $f
} -result 牦
test chan-io-39.16 {Tcl_SetChannelOption: -encoding, errors} -setup {
file delete $path(test1)
set f [open $path(test1) w]
} -body {
chan configure $f -encoding foobar
} -returnCodes error -cleanup {
chan close $f
} -result {unknown encoding "foobar"}
test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} -setup {
variable x {}
} -constraints {stdio fileevent} -body {
set f [openpipe r+ $path(cat)]
chan configure $f -encoding iso8859-1
chan puts -nonewline $f \xE7
chan flush $f
chan configure $f -encoding utf-8 -blocking 0
chan event $f readable [namespace code { lappend x [chan read $f] }]
vwait [namespace which -variable x]
after 300 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
chan configure $f -encoding utf-8
vwait [namespace which -variable x]
after 300 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
chan configure $f -encoding iso8859-1
vwait [namespace which -variable x]
after 300 [namespace code { lappend x timeout }]
vwait [namespace which -variable x]
return $x
} -cleanup {
chan close $f
} -result "{} timeout {} timeout \xE7 timeout"
|
| ︙ | ︙ | |||
5371 5372 5373 5374 5375 5376 5377 |
file stat $path(test3) stats
format 0o%03o [expr {$stats(mode) & 0o777}]
} -result [format 0o%03o [expr {0o666 & ~ $umaskValue}]]
test chan-io-40.4 {POSIX open access modes: CREAT} -setup {
file delete $path(test3)
} -body {
set f [open $path(test3) w]
| < < | | 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 |
file stat $path(test3) stats
format 0o%03o [expr {$stats(mode) & 0o777}]
} -result [format 0o%03o [expr {0o666 & ~ $umaskValue}]]
test chan-io-40.4 {POSIX open access modes: CREAT} -setup {
file delete $path(test3)
} -body {
set f [open $path(test3) w]
chan puts $f xyzzy
chan close $f
set f [open $path(test3) {WRONLY CREAT}]
chan puts -nonewline $f "ab"
chan close $f
set f [open $path(test3) r]
chan gets $f
} -cleanup {
chan close $f
} -result abzzy
test chan-io-40.5 {POSIX open access modes: APPEND} -setup {
file delete $path(test3)
set x ""
} -body {
set f [open $path(test3) w]
chan configure $f -translation lf
chan puts $f xyzzy
chan close $f
set f [open $path(test3) {WRONLY APPEND}]
chan configure $f -translation lf
chan puts $f "new line"
chan seek $f 0
chan puts $f "abc"
|
| ︙ | ︙ | |||
5417 5418 5419 5420 5421 5422 5423 |
chan close $f
open $path(test3) {WRONLY CREAT EXCL}
} -returnCodes error -result {(?i)couldn't open ".*test3": file (already )?exists}
test chan-io-40.7 {POSIX open access modes: EXCL} -setup {
file delete $path(test3)
} -body {
set f [open $path(test3) {WRONLY CREAT EXCL}]
| < | 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 |
chan close $f
open $path(test3) {WRONLY CREAT EXCL}
} -returnCodes error -result {(?i)couldn't open ".*test3": file (already )?exists}
test chan-io-40.7 {POSIX open access modes: EXCL} -setup {
file delete $path(test3)
} -body {
set f [open $path(test3) {WRONLY CREAT EXCL}]
chan puts $f "A test line"
chan close $f
viewFile test3
} -result {A test line}
test chan-io-40.8 {POSIX open access modes: TRUNC} -setup {
file delete $path(test3)
} -body {
|
| ︙ | ︙ | |||
5468 5469 5470 5471 5472 5473 5474 |
test chan-io-40.12 {POSIX open access modes: WRONLY} -match regexp -body {
file delete $path(test3)
open $path(test3) WRONLY
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test chan-io-40.13 {POSIX open access modes: WRONLY} -body {
makeFile xyzzy test3
set f [open $path(test3) WRONLY]
| < | 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 |
test chan-io-40.12 {POSIX open access modes: WRONLY} -match regexp -body {
file delete $path(test3)
open $path(test3) WRONLY
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test chan-io-40.13 {POSIX open access modes: WRONLY} -body {
makeFile xyzzy test3
set f [open $path(test3) WRONLY]
chan puts -nonewline $f "ab"
chan seek $f 0 current
set x [list [catch {chan gets $f} msg] $msg]
chan close $f
lappend x [viewFile test3]
} -match glob -result {1 {channel "*" wasn't opened for reading} abzzy}
test chan-io-40.14 {POSIX open access modes: RDWR} -match regexp -body {
|
| ︙ | ︙ | |||
6731 6732 6733 6734 6735 6736 6737 |
lappend result [file size $path(test1)]
} -result {0 0 40}
test chan-io-52.5 {TclCopyChannel, all} -constraints {fcopy} -setup {
file delete $path(test1)
} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
| | | | | | | | | | | | 6716 6717 6718 6719 6720 6721 6722 6723 6724 6725 6726 6727 6728 6729 6730 6731 6732 6733 6734 6735 6736 6737 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 6770 6771 6772 6773 6774 6775 6776 6777 6778 6779 6780 6781 6782 6783 6784 6785 6786 6787 6788 6789 6790 6791 6792 6793 6794 6795 6796 6797 |
lappend result [file size $path(test1)]
} -result {0 0 40}
test chan-io-52.5 {TclCopyChannel, all} -constraints {fcopy} -setup {
file delete $path(test1)
} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation binary -blocking 0
chan configure $f2 -translation binary -blocking 0
chan copy $f1 $f2 -size -1 ;# -1 means 'copy all', same as if no -size specified.
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
chan close $f1
chan close $f2
if {[file size $thisScript] == [file size $path(test1)]} {
lappend result ok
}
return $result
} -result {0 0 ok}
test chan-io-52.5a {TclCopyChannel, all, other negative value} -setup {
file delete $path(test1)
} -constraints {fcopy} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation binary -blocking 0
chan configure $f2 -translation binary -blocking 0
chan copy $f1 $f2 -size -2 ;# < 0 behaves like -1, copy all
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
chan close $f1
chan close $f2
if {[file size $thisScript] == [file size $path(test1)]} {
lappend result ok
}
return $result
} -result {0 0 ok}
test chan-io-52.5b {TclCopyChannel, all, wrap to negative value} -setup {
file delete $path(test1)
} -constraints {fcopy} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation binary -blocking 0
chan configure $f2 -translation binary -blocking 0
chan copy $f1 $f2 -size 3221176172 ;# Wrapped to < 0, behaves like -1, copy all
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
chan close $f1
chan close $f2
if {[file size $thisScript] == [file size $path(test1)]} {
lappend result ok
}
return $result
} -result {0 0 ok}
test chan-io-52.6 {TclCopyChannel} -setup {
file delete $path(test1)
} -constraints {fcopy} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation binary -blocking 0
chan configure $f2 -translation binary -blocking 0
set s0 [chan copy $f1 $f2 -size [expr {[file size $thisScript] + 5}]]
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
chan close $f1
chan close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {($s1 == $s2) && ($s0 == $s1)} {
lappend result ok
}
return $result
} -result {0 0 ok}
test chan-io-52.7 {TclCopyChannel} -constraints {fcopy} -setup {
file delete $path(test1)
} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation binary -blocking 0
chan configure $f2 -translation binary -blocking 0
chan copy $f1 $f2
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
if {[file size $thisScript] == [file size $path(test1)]} {
lappend result ok
}
return $result
} -cleanup {
|
| ︙ | ︙ | |||
6870 6871 6872 6873 6874 6875 6876 |
[file size $path(utf8-fcopy.txt)] \
[file size $path(utf8-rp.txt)]
} {3 5 5}
test chan-io-52.10 {TclCopyChannel & encodings} -constraints {fcopy} -body {
set in [open $path(kyrillic.txt) r]
set out [open $path(utf8-fcopy.txt) w]
chan configure $in -encoding koi8-r -translation lf
| < < | 6855 6856 6857 6858 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 |
[file size $path(utf8-fcopy.txt)] \
[file size $path(utf8-rp.txt)]
} {3 5 5}
test chan-io-52.10 {TclCopyChannel & encodings} -constraints {fcopy} -body {
set in [open $path(kyrillic.txt) r]
set out [open $path(utf8-fcopy.txt) w]
chan configure $in -encoding koi8-r -translation lf
chan configure $out -translation binary
chan copy $in $out
file size $path(utf8-fcopy.txt)
} -cleanup {
chan close $in
chan close $out
unset in out
} -returnCodes 1 -match glob -result {error writing "*":\
invalid or incomplete multibyte or wide character}
test chan-io-52.11 {TclCopyChannel & encodings} -setup {
set f [open $path(utf8-fcopy.txt) w]
fconfigure $f -encoding utf-8 -translation lf
puts $f АА
close $f
} -constraints {fcopy} -body {
set in [open $path(utf8-fcopy.txt) r]
set out [open $path(kyrillic.txt) w]
chan configure $in -translation binary
chan configure $out -encoding koi8-r -translation lf -profile strict
catch {chan copy $in $out} cres copts
return $cres
} -cleanup {
if {$in in [chan names]} {
close $in
|
| ︙ | ︙ |
Changes to tests/cmdAH.test.
| ︙ | ︙ | |||
1796 1797 1798 1799 1800 1801 1802 |
# size
test cmdAH-27.1 {Tcl_FileObjCmd: size} -returnCodes error -body {
file size a b
} -result {wrong # args: should be "file size name"}
test cmdAH-27.2 {Tcl_FileObjCmd: size} {
set oldsize [file size $gorpfile]
set f [open $gorpfile a]
| | | 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 |
# size
test cmdAH-27.1 {Tcl_FileObjCmd: size} -returnCodes error -body {
file size a b
} -result {wrong # args: should be "file size name"}
test cmdAH-27.2 {Tcl_FileObjCmd: size} {
set oldsize [file size $gorpfile]
set f [open $gorpfile a]
fconfigure $f -translation lf
puts $f "More text"
close $f
expr {[file size $gorpfile] - $oldsize}
} {10}
test cmdAH-27.3 {Tcl_FileObjCmd: size} {
list [catch {file size _bogus_} msg] [string tolower $msg] $errorCode
} {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}}
|
| ︙ | ︙ |
Changes to tests/encoding.test.
| ︙ | ︙ | |||
185 186 187 188 189 190 191 |
append a $a
set x [encoding convertfrom jis0208 $a]
list [string length $x] [string index $x 0]
} "512 乎"
test encoding-8.1 {Tcl_ExternalToUtf} {
set f [open [file join [temporaryDirectory] dummy] w]
| | | | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 |
append a $a
set x [encoding convertfrom jis0208 $a]
list [string length $x] [string index $x 0]
} "512 乎"
test encoding-8.1 {Tcl_ExternalToUtf} {
set f [open [file join [temporaryDirectory] dummy] w]
fconfigure $f -translation binary
puts -nonewline $f "ab\x8C\xC1g"
close $f
set f [open [file join [temporaryDirectory] dummy] r]
fconfigure $f -translation lf -encoding shiftjis
set x [read $f]
close $f
file delete [file join [temporaryDirectory] dummy]
return $x
} ab乎g
test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} {
|
| ︙ | ︙ | |||
213 214 215 216 217 218 219 |
append a $a
set x [encoding convertto jis0208 $a]
list [string length $x] [string range $x 0 1]
} "1024 8C"
test encoding-10.1 {Tcl_UtfToExternal} {
set f [open [file join [temporaryDirectory] dummy] w]
| | | | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 |
append a $a
set x [encoding convertto jis0208 $a]
list [string length $x] [string range $x 0 1]
} "1024 8C"
test encoding-10.1 {Tcl_UtfToExternal} {
set f [open [file join [temporaryDirectory] dummy] w]
fconfigure $f -translation lf -encoding shiftjis
puts -nonewline $f ab乎g
close $f
set f [open [file join [temporaryDirectory] dummy] r]
fconfigure $f -translation binary
set x [read $f]
close $f
file delete [file join [temporaryDirectory] dummy]
return $x
} "ab\x8C\xC1g"
test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} {
|
| ︙ | ︙ | |||
675 676 677 678 679 680 681 | 小切手送付先として使用しております。恐れ入りますが、正しい住所をご登録しなお お願いいたします。また、大変恐縮ですが、住所変更のあと、日本語サービス部（ casino_japanese@___.com ）までご住所変更済の連絡をいただけないで しょうか？" cd [temporaryDirectory] set fid [open iso2022.txt w] | | | 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 |
小切手送付先として使用しております。恐れ入りますが、正しい住所をご登録しなお
お願いいたします。また、大変恐縮ですが、住所変更のあと、日本語サービス部（
casino_japanese@___.com ）までご住所変更済の連絡をいただけないで
しょうか？"
cd [temporaryDirectory]
set fid [open iso2022.txt w]
fconfigure $fid -translation binary
puts -nonewline $fid $iso2022encData
close $fid
test encoding-23.1 {iso2022-jp escape encoding test} {
string equal $iso2022uniData $iso2022uniData2
} 1
test encoding-23.2 {iso2022-jp escape encoding test} {
|
| ︙ | ︙ | |||
990 991 992 993 994 995 996 |
return $diff
}
# Create char tables.
cd [temporaryDirectory]
foreach enc {cp932 euc-jp iso2022-jp} {
set f [open $enc.chars w]
| | | 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 |
return $diff
}
# Create char tables.
cd [temporaryDirectory]
foreach enc {cp932 euc-jp iso2022-jp} {
set f [open $enc.chars w]
fconfigure $f -encoding iso8859-1
foreach-jisx0208 code {
puts $f [format "%04X %s" $code [gen-jisx0208-$enc $code]]
}
close $f
}
# shiftjis == cp932 for jisx0208.
file copy -force cp932.chars shiftjis.chars
|
| ︙ | ︙ |
Changes to tests/io.test.
| ︙ | ︙ | |||
63 64 65 66 67 68 69 |
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]
| | | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 |
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
|
| ︙ | ︙ | |||
106 107 108 109 110 111 112 |
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]
| | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 |
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
|
| ︙ | ︙ | |||
242 243 244 245 246 247 248 |
testreadwrite 0xffffffff
} -result 1
test io-2.1 {WriteBytes} {
# loop until all bytes are written
set f [open $path(test1) w]
| | | | | < | 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 |
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
|
| ︙ | ︙ | |||
1176 1177 1178 1179 1180 1181 1182 |
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]
| | | | | | 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 |
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]
|
| ︙ | ︙ | |||
1275 1276 1277 1278 1279 1280 1281 |
# 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)]
| | | 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 |
# 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
|
| ︙ | ︙ | |||
1392 1393 1394 1395 1396 1397 1398 |
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)]
| | | | | | 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 |
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} {
|
| ︙ | ︙ | |||
1479 1480 1481 1482 1483 1484 1485 |
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+]
| | | | | 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 |
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]
|
| ︙ | ︙ | |||
2225 2226 2227 2228 2229 2230 2231 |
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]
| | | 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 |
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]
|
| ︙ | ︙ | |||
2274 2275 2276 2277 2278 2279 2280 |
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]
| | | | | | 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 |
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
|
| ︙ | ︙ | |||
2337 2338 2339 2340 2341 2342 2343 |
# 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 {
| | | 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 |
# 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
|
| ︙ | ︙ | |||
2408 2409 2410 2411 2412 2413 2414 |
set f [open $path(pipe) w]
puts $f {
# Need to not have eof char appended on close, because the other
# side of the pipe already closed, so that writing would cause an
# error "invalid file".
| | | | | 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 |
set f [open $path(pipe) w]
puts $f {
# Need to not have eof char appended on close, because the other
# side of the pipe already closed, so that writing would cause an
# error "invalid file".
fconfigure stdout
fconfigure stderr
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]
|
| ︙ | ︙ | |||
2560 2561 2562 2563 2564 2565 2566 |
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]
| | | | | | | | 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 |
test io-29.1 {Tcl_WriteChars, channel not writable} {
list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.2 {Tcl_WriteChars, empty string} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f
puts -nonewline $f ""
close $f
file size $path(test1)
} 0
test io-29.3 {Tcl_WriteChars, nonempty string} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f
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)]
|
| ︙ | ︙ | |||
2658 2659 2660 2661 2662 2663 2664 |
} {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]
| | | | 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 |
} {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]
fconfigure $f1
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)
|
| ︙ | ︙ | |||
2796 2797 2798 2799 2800 2801 2802 |
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]
| | | | 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 |
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} {
|
| ︙ | ︙ | |||
2952 2953 2954 2955 2956 2957 2958 |
}
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]
| | | | | 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 |
}
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.
|
| ︙ | ︙ | |||
3544 3545 3546 3547 3548 3549 3550 |
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]
| | | | | | | | 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 |
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
|
| ︙ | ︙ | |||
4080 4081 4082 4083 4084 4085 4086 |
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]
| | | | | | | | 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 |
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]
|
| ︙ | ︙ | |||
4182 4183 4184 4185 4186 4187 4188 |
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]
| | | | | | 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 |
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]
|
| ︙ | ︙ | |||
4605 4606 4607 4608 4609 4610 4611 |
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]
| | | | | 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 |
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}
|
| ︙ | ︙ | |||
4759 4760 4761 4762 4763 4764 4765 |
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]
| | | | | | | | 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 |
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]
|
| ︙ | ︙ | |||
4850 4851 4852 4853 4854 4855 4856 |
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]
| | | 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 |
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]
fconfigure $f
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
|
| ︙ | ︙ | |||
4898 4899 4900 4901 4902 4903 4904 |
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]
| | | | | | 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 |
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
|
| ︙ | ︙ | |||
4966 4967 4968 4969 4970 4971 4972 |
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]
| | | | 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 |
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
|
| ︙ | ︙ | |||
5012 5013 5014 5015 5016 5017 5018 |
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]
| | | 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 |
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!
|
| ︙ | ︙ | |||
5206 5207 5208 5209 5210 5211 5212 |
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]
| | | | | | | | 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 |
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]]
|
| ︙ | ︙ | |||
5352 5353 5354 5355 5356 5357 5358 |
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]
| | | | 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 |
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]]]
|
| ︙ | ︙ | |||
5403 5404 5405 5406 5407 5408 5409 |
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+]
| | | | 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 |
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 ""
|
| ︙ | ︙ | |||
5653 5654 5655 5656 5657 5658 5659 |
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 ""
| | | 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 |
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)]
|
| ︙ | ︙ | |||
5748 5749 5750 5751 5752 5753 5754 |
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]
| | | | 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 |
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
|
| ︙ | ︙ | |||
5785 5786 5787 5788 5789 5790 5791 |
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+]
| | | | 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 |
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} \
|
| ︙ | ︙ | |||
5937 5938 5939 5940 5941 5942 5943 |
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]
| | | | | 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 |
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]
fconfigure $f
puts $f xyzzy
close $f
set f [open $path(test3) {WRONLY CREAT}]
fconfigure $f
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"
|
| ︙ | ︙ | |||
5980 5981 5982 5983 5984 5985 5986 |
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}]
| | | 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 |
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}]
fconfigure $f
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]
|
| ︙ | ︙ | |||
6031 6032 6033 6034 6035 6036 6037 |
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]
| | | 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 |
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]
fconfigure $f
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]
|
| ︙ | ︙ | |||
7601 7602 7603 7604 7605 7606 7607 |
[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
| < < | 7600 7601 7602 7603 7604 7605 7606 7607 7608 7609 7610 7611 7612 7613 7614 7615 7616 7617 7618 7619 7620 7621 7622 7623 7624 7625 7626 7627 7628 7629 7630 7631 |
[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
|
| ︙ | ︙ | |||
9326 9327 9328 9329 9330 9331 9332 |
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+]
| | | 9323 9324 9325 9326 9327 9328 9329 9330 9331 9332 9333 9334 9335 9336 9337 |
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 {
|
| ︙ | ︙ | |||
9362 9363 9364 9365 9366 9367 9368 |
# 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+]
| | | | | | | | | | | | | | | | | | | 9359 9360 9361 9362 9363 9364 9365 9366 9367 9368 9369 9370 9371 9372 9373 9374 9375 9376 9377 9378 9379 9380 9381 9382 9383 9384 9385 9386 9387 9388 9389 9390 9391 9392 9393 9394 9395 9396 9397 9398 9399 9400 9401 9402 9403 9404 9405 9406 9407 9408 9409 9410 9411 9412 9413 9414 9415 9416 9417 9418 9419 9420 9421 9422 9423 9424 9425 9426 9427 9428 9429 9430 9431 9432 9433 9434 9435 9436 9437 9438 9439 9440 9441 9442 9443 9444 9445 9446 9447 9448 9449 9450 9451 9452 9453 9454 9455 9456 9457 9458 9459 9460 9461 9462 9463 9464 9465 9466 9467 9468 9469 9470 9471 9472 9473 9474 9475 9476 9477 9478 9479 9480 9481 9482 9483 9484 9485 9486 9487 9488 9489 9490 9491 9492 9493 9494 9495 9496 9497 9498 9499 9500 9501 9502 9503 9504 9505 9506 9507 9508 9509 9510 9511 9512 9513 9514 9515 9516 9517 9518 9519 9520 9521 9522 9523 9524 9525 9526 9527 9528 9529 9530 9531 9532 9533 9534 9535 9536 9537 9538 9539 9540 9541 9542 9543 9544 9545 |
# 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 {incomplete utf-8 encoding, blocking 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 {
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 -data]
} -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 utf-8 encoding eof first handling (-profile strict)} -setup {
set fn [makeFile {} io-75.8]
set f [open $fn w+]
fconfigure $f -translation binary
# \x81 is invalid in utf-8, but since \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
|
| ︙ | ︙ | |||
9558 9559 9560 9561 9562 9563 9564 |
unset f d hd
} -result {41 1 {}}
test io-75.8.eoflater {invalid utf-8 encoding eof after handling (-profile strict)} -setup {
set fn [makeFile {} io-75.8]
set f [open $fn w+]
# This also configures the channel encoding profile as strict.
| | | 9555 9556 9557 9558 9559 9560 9561 9562 9563 9564 9565 9566 9567 9568 9569 |
unset f d hd
} -result {41 1 {}}
test io-75.8.eoflater {invalid utf-8 encoding eof after 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 {
|
| ︙ | ︙ | |||
9585 9586 9587 9588 9589 9590 9591 |
test io-strict-multibyte-eof {
incomplete utf-8 sequence immediately prior to eof character
See issue 25cdcb7e8fb381fb
} -setup {
set chan [file tempfile];
| | | 9582 9583 9584 9585 9586 9587 9588 9589 9590 9591 9592 9593 9594 9595 9596 |
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 [dict get $data -data]
} -cleanup {
|
| ︙ | ︙ | |||
9621 9622 9623 9624 9625 9626 9627 |
test io-75.10 {
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+]
| | | 9618 9619 9620 9621 9622 9623 9624 9625 9626 9627 9628 9629 9630 9631 9632 |
test io-75.10 {
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
|
| ︙ | ︙ | |||
9650 9651 9652 9653 9654 9655 9656 |
# 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+]
| | | | | | 9647 9648 9649 9650 9651 9652 9653 9654 9655 9656 9657 9658 9659 9660 9661 9662 9663 9664 9665 9666 9667 9668 9669 9670 9671 9672 9673 9674 9675 9676 9677 9678 9679 9680 9681 9682 9683 9684 9685 9686 9687 9688 9689 9690 9691 |
# 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 -data]
} -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}
test io-75.12 {
invalid utf-8 encoding read is not ignored because setting the encoding to
"binary" also set 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
|
| ︙ | ︙ | |||
9703 9704 9705 9706 9707 9708 9709 |
test io-75.13 {
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+]
| | | | | | 9700 9701 9702 9703 9704 9705 9706 9707 9708 9709 9710 9711 9712 9713 9714 9715 9716 9717 9718 9719 9720 9721 9722 9723 9724 9725 9726 9727 9728 9729 9730 9731 9732 9733 9734 9735 9736 9737 9738 9739 9740 9741 9742 9743 |
test io-75.13 {
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 -data]
} -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 [dict exists $data -data]
chan configure $chan -profile tcl8
lappend res [gets $chan]
|
| ︙ | ︙ | |||
9755 9756 9757 9758 9759 9760 9761 |
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]
| | | 9752 9753 9754 9755 9756 9757 9758 9759 9760 9761 9762 9763 9764 9765 9766 |
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]
|
| ︙ | ︙ |
Changes to tests/ioCmd.test.
| ︙ | ︙ | |||
44 45 46 47 48 49 50 |
list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
set path(test1) [makeFile {} test1]
test iocmd-1.6 {puts command} {
set f [open $path(test1) w]
| | | | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
set path(test1) [makeFile {} test1]
test iocmd-1.6 {puts command} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f foobar
close $f
file size $path(test1)
} 6
test iocmd-1.7 {puts command} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f foobar
close $f
file size $path(test1)
} 7
test iocmd-1.8 {puts command} {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f [binary format a4a5 foo bar]
close $f
file size $path(test1)
} 9
test iocmd-2.1 {flush command} {
list [catch {flush} msg] $msg
|
| ︙ | ︙ | |||
237 238 239 240 241 242 243 |
test iocmd-8.6 {fconfigure command} -returnCodes error -body {
fconfigure stdin -translation froboz
} -result {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}
test iocmd-8.7 {fconfigure command} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
| | | | < | 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
test iocmd-8.6 {fconfigure command} -returnCodes error -body {
fconfigure stdin -translation froboz
} -result {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}
test iocmd-8.7 {fconfigure command} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -encoding utf-16
fconfigure $f1
} -cleanup {
catch {close $f1}
} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -profile strict -translation lf}
test iocmd-8.8 {fconfigure command} -setup {
file delete $path(test1)
set x {}
} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -buffering line -buffersize 3030 \
-encoding utf-16 -profile tcl8
lappend x [fconfigure $f1 -buffering]
lappend x [fconfigure $f1]
} -cleanup {
catch {close $f1}
} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -profile tcl8 -translation lf}}
test iocmd-8.9 {fconfigure command} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation binary -buffering none -buffersize 4040
fconfigure $f1
} -cleanup {
catch {close $f1}
} -result {-blocking 1 -buffering none -buffersize 4040 -encoding iso8859-1 -eofchar {} -profile strict -translation lf}
test iocmd-8.10 {fconfigure command} -returnCodes error -body {
fconfigure a b
} -result {can not find channel named "a"}
|
| ︙ | ︙ | |||
443 444 445 446 447 448 449 |
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
#
# Test 13.4 relies on assigning the same channel name twice.
#
test iocmd-12.4 {POSIX open access modes: WRONLY} {unix} {
file delete $path(test3)
set f [open $path(test3) w]
| | | | | 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 |
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
#
# Test 13.4 relies on assigning the same channel name twice.
#
test iocmd-12.4 {POSIX open access modes: WRONLY} {unix} {
file delete $path(test3)
set f [open $path(test3) w]
fconfigure $f
puts $f xyzzy
close $f
set f [open $path(test3) WRONLY]
fconfigure $f
puts -nonewline $f "ab"
seek $f 0 current
set x [list [catch {gets $f} msg] $msg]
close $f
set f [open $path(test3) r]
fconfigure $f
lappend x [gets $f]
close $f
set y [list 1 [format "channel \"%s\" wasn't opened for reading" $f] abzzy]
string compare $x $y
} 0
test iocmd-12.5 {POSIX open access modes: RDWR} -match regexp -body {
file delete $path(test3)
|
| ︙ | ︙ | |||
1389 1390 1391 1392 1393 1394 1395 |
set res {}
proc foo args {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}
set c [chan create {r w} foo]
note [fconfigure $c]
close $c
rename foo {}
set res
| | | | | 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 |
set res {}
proc foo args {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}
set c [chan create {r w} foo]
note [fconfigure $c]
close $c
rename foo {}
set res
} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -profile * -translation {auto *}}}
test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body {
set res {}
proc foo args {oninit cget cgetall; onfinal; track; return ""}
set c [chan create {r w} foo]
note [fconfigure $c]
close $c
rename foo {}
set res
} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -profile * -translation {auto *}}}
test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body {
set res {}
proc foo args {
oninit cget cgetall; onfinal; track
return {-bar foo -snarf x}
}
set c [chan create {r w} foo]
note [fconfigure $c]
close $c
rename foo {}
set res
} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -profile * -translation {auto *} -bar foo -snarf x}}
test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body {
set res {}
proc foo {args} {
oninit cget cgetall; onfinal; track
return "-bar"
}
set c [chan create {r w} foo]
|
| ︙ | ︙ | |||
2974 2975 2976 2977 2978 2979 2980 |
note [fconfigure $c]
close $c
notes
} c]
rename foo {}
set res
} -constraints {testchannel thread} \
| | | | | 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 |
note [fconfigure $c]
close $c
notes
} c]
rename foo {}
set res
} -constraints {testchannel thread} \
-result {{-blocking 1 -buffering full -buffersize 4096 -encoding * * -translation {auto *}}}
test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body {
set res {}
proc foo {args} {oninit cget cgetall; onfinal; track; return ""}
set c [chan create {r w} foo]
notes [inthread $c {
note [fconfigure $c]
close $c
notes
} c]
rename foo {}
set res
} -constraints {testchannel thread} \
-result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * * -translation {auto *}}}
test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body {
set res {}
proc foo {args} {
oninit cget cgetall; onfinal; track
return "-bar foo -snarf x"
}
set c [chan create {r w} foo]
notes [inthread $c {
note [fconfigure $c]
close $c
notes
} c]
rename foo {}
set res
} -constraints {testchannel thread} \
-result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * * -translation {auto *} -bar foo -snarf x}}
test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body {
set res {}
proc foo {args} {
oninit cget cgetall; onfinal; track
return "-bar"
}
set c [chan create {r w} foo]
|
| ︙ | ︙ |
Changes to tests/macOSXFCmd.test.
| ︙ | ︙ | |||
100 101 102 103 104 105 106 |
[file delete -force -- foo.test]
} {0 {} 0 1 {}}
test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoot nonPortable} {
catch {file delete -force -- foo.test}
close [open foo.test w]
catch {
set f [open foo.test/..namedfork/rsrc w]
| | | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 |
[file delete -force -- foo.test]
} {0 {} 0 1 {}}
test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoot nonPortable} {
catch {file delete -force -- foo.test}
close [open foo.test w]
catch {
set f [open foo.test/..namedfork/rsrc w]
fconfigure $f -translation lf
puts -nonewline $f "foo"
close $f
}
list [catch {file attributes foo.test -rsrclength} msg] $msg \
[catch {file attributes foo.test -rsrclength 0} msg] $msg \
[catch {file attributes foo.test -rsrclength} msg] $msg \
[file delete -force -- foo.test]
} {0 3 0 {} 0 0 {}}
test macOSXFCmd-3.1 {MacOSXCopyFileAttributes} {macosxFileAttr notRoot} {
catch {file delete -force -- foo.test}
catch {file delete -force -- bar.test}
close [open foo.test w]
catch {
file attributes foo.test -creator FOOC -type FOOT -hidden 1
set f [open foo.test/..namedfork/rsrc w]
fconfigure $f -translation lf
puts -nonewline $f "foo"
close $f
file copy foo.test bar.test
}
list [catch {file attributes bar.test -creator} msg] $msg \
[catch {file attributes bar.test -type} msg] $msg \
[catch {file attributes bar.test -hidden} msg] $msg \
|
| ︙ | ︙ |
Added tools/ucm2tests.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
# ucm2tests.tcl
#
# Parses given ucm files (from ICU) to generate test data
# for encodings.
#
# tclsh ucm2tests.tcl PATH_TO_ICU_UCM_DIRECTORY ?OUTPUTPATH?
#
namespace eval ucm {
# No means to change these currently but ...
variable outputPath
variable outputChan
variable errorChan stderr
variable verbose 0
# Map Tcl encoding name to ICU UCM file name
variable encNameMap
array set encNameMap {
cp1250 glibc-CP1250-2.1.2
cp1251 glibc-CP1251-2.1.2
cp1252 glibc-CP1252-2.1.2
cp1253 glibc-CP1253-2.1.2
cp1254 glibc-CP1254-2.1.2
cp1255 glibc-CP1255-2.1.2
cp1256 glibc-CP1256-2.1.2
cp1257 glibc-CP1257-2.1.2
cp1258 glibc-CP1258-2.1.2
gb1988 glibc-GB_1988_80-2.3.3
iso8859-1 glibc-ISO_8859_1-2.1.2
iso8859-2 glibc-ISO_8859_2-2.1.2
iso8859-3 glibc-ISO_8859_3-2.1.2
iso8859-4 glibc-ISO_8859_4-2.1.2
iso8859-5 glibc-ISO_8859_5-2.1.2
iso8859-6 glibc-ISO_8859_6-2.1.2
iso8859-7 glibc-ISO_8859_7-2.3.3
iso8859-8 glibc-ISO_8859_8-2.3.3
iso8859-9 glibc-ISO_8859_9-2.1.2
iso8859-10 glibc-ISO_8859_10-2.1.2
iso8859-11 glibc-ISO_8859_11-2.1.2
iso8859-13 glibc-ISO_8859_13-2.3.3
iso8859-14 glibc-ISO_8859_14-2.1.2
iso8859-15 glibc-ISO_8859_15-2.1.2
iso8859-16 glibc-ISO_8859_16-2.3.3
}
# Array keyed by Tcl encoding name. Each element contains mapping of
# Unicode code point -> byte sequence for that encoding as a flat list
# (or dictionary). Both are stored as hex strings
variable charMap
# Array keyed by Tcl encoding name. List of invalid code sequences
# each being a hex string.
variable invalidCodeSequences
# Array keyed by Tcl encoding name. List of unicode code points that are
# not mapped, each being a hex string.
variable unmappedCodePoints
# The fallback character per encoding
variable encSubchar
}
proc ucm::abort {msg} {
variable errorChan
puts $errorChan $msg
exit 1
}
proc ucm::warn {msg} {
variable errorChan
puts $errorChan $msg
}
proc ucm::log {msg} {
variable verbose
if {$verbose} {
variable errorChan
puts $errorChan $msg
}
}
proc ucm::print {s} {
variable outputChan
puts $outputChan $s
}
proc ucm::parse_SBCS {encName fd} {
variable charMap
variable invalidCodeSequences
variable unmappedCodePoints
set result {}
while {[gets $fd line] >= 0} {
if {[string match #* $line]} {
continue
}
if {[string equal "END CHARMAP" [string trim $line]]} {
break
}
if {![regexp {^\s*<U([[:xdigit:]]{4})>\s*((\\x[[:xdigit:]]{2})+)\s*(\|(0|1|2|3|4))} $line -> unichar bytes - - precision]} {
error "Unexpected line parsing SBCS: $line"
}
set bytes [string map {\\x {}} $bytes]; # \xNN -> NN
if {$precision eq "" || $precision eq "0"} {
lappend result $unichar $bytes
} else {
# It is a fallback mapping - ignore
}
}
set charMap($encName) $result
# Find out invalid code sequences and unicode code points that are not mapped
set valid {}
set mapped {}
foreach {unich bytes} $result {
lappend mapped $unich
lappend valid $bytes
}
set invalidCodeSequences($encName) {}
for {set i 0} {$i <= 255} {incr i} {
set hex [format %.2X $i]
if {[lsearch -exact $valid $hex] < 0} {
lappend invalidCodeSequences($encName) $hex
}
}
set unmappedCodePoints($encName) {}
for {set i 0} {$i <= 65535} {incr i} {
set hex [format %.4X $i]
if {[lsearch -exact $mapped $hex] < 0} {
lappend unmappedCodePoints($encName) $hex
# Only look for (at most) one below 256 and one above 1024
if {$i < 255} {
# Found one so jump past 8 bits
set i 255
} else {
break
}
}
if {$i == 255} {
set i 1023
}
}
lappend unmappedCodePoints($encName) D800 DC00 10000 10FFFF
}
proc ucm::generate_boilerplate {} {
# Common procedures
print {
# This file is automatically generated by ucm2tests.tcl.
# Edits will be overwritten on next generation.
#
# Generates tests comparing Tcl encodings to ICU.
# The generated file is NOT standalone. It should be sourced into a test script.
proc ucmConvertfromMismatches {enc map} {
set mismatches {}
foreach {unihex hex} $map {
set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits
set unich [subst "\\U$unihex"]
if {[encoding convertfrom -profile strict $enc [binary decode hex $hex]] ne $unich} {
lappend mismatches "<[printable $unich],$hex>"
}
}
return $mismatches
}
proc ucmConverttoMismatches {enc map} {
set mismatches {}
foreach {unihex hex} $map {
set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits
set unich [subst "\\U$unihex"]
if {[encoding convertto -profile strict $enc $unich] ne [binary decode hex $hex]} {
lappend mismatches "<[printable $unich],$hex>"
}
}
return $mismatches
}
if {[info commands printable] eq ""} {
proc printable {s} {
set print ""
foreach c [split $s ""] {
set i [scan $c %c]
if {[string is print $c] && ($i <= 127)} {
append print $c
} elseif {$i <= 0xff} {
append print \\x[format %02X $i]
} elseif {$i <= 0xffff} {
append print \\u[format %04X $i]
} else {
append print \\U[format %08X $i]
}
}
return $print
}
}
}
} ; # generate_boilerplate
proc ucm::generate_tests {} {
variable encNameMap
variable charMap
variable invalidCodeSequences
variable unmappedCodePoints
variable outputPath
variable outputChan
variable encSubchar
if {[info exists outputPath]} {
set outputChan [open $outputPath w]
fconfigure $outputChan -translation lf
} else {
set outputChan stdout
}
array set tclNames {}
foreach encName [encoding names] {
set tclNames($encName) ""
}
generate_boilerplate
foreach encName [lsort -dictionary [array names encNameMap]] {
if {![info exists charMap($encName)]} {
warn "No character map read for $encName"
continue
}
unset tclNames($encName)
# Print the valid tests
print "\n#\n# $encName (generated from $encNameMap($encName))"
print "\ntest encoding-convertfrom-ucmCompare-$encName {Compare against ICU UCM} -body \{"
print " ucmConvertfromMismatches $encName {$charMap($encName)}"
print "\} -result {}"
print "\ntest encoding-convertto-ucmCompare-$encName {Compare against ICU UCM} -body \{"
print " ucmConverttoMismatches $encName {$charMap($encName)}"
print "\} -result {}"
if {0} {
# This will generate individual tests for every char
# and test in lead, tail, middle, solo configurations
# but takes considerable time
print "lappend encValidStrings \{*\}\{"
foreach {unich hex} $charMap($encName) {
print " $encName \\u$unich $hex {} {}"
}
print "\}; # $encName"
}
# Generate the invalidity checks
print "\n# $encName - invalid byte sequences"
print "lappend encInvalidBytes \{*\}\{"
foreach hex $invalidCodeSequences($encName) {
# Map XXXX... to \xXX\xXX...
set uhex [regsub -all .. $hex {\\x\0}]
set uhex \\U[string range 00000000$hex end-7 end]
print " $encName $hex tcl8 $uhex -1 {} {}"
print " $encName $hex replace \\uFFFD -1 {} {}"
print " $encName $hex strict {} 0 {} {}"
}
print "\}; # $encName"
print "\n# $encName - invalid byte sequences"
print "lappend encUnencodableStrings \{*\}\{"
if {[info exists encSubchar($encName)]} {
set subchar $encSubchar($encName)
} else {
set subchar "3F"; # Tcl uses ? by default
}
foreach hex $unmappedCodePoints($encName) {
set uhex \\U[string range 00000000$hex end-7 end]
print " $encName $uhex tcl8 $subchar -1 {} {}"
print " $encName $uhex replace $subchar -1 {} {}"
print " $encName $uhex strict {} 0 {} {}"
}
print "\}; # $encName"
}
if {[array size tclNames]} {
warn "Missing encoding: [lsort [array names tclNames]]"
}
if {[info exists outputPath]} {
close $outputChan
unset outputChan
}
}
proc ucm::parse_file {encName ucmPath} {
variable charMap
variable encSubchar
set fd [open $ucmPath]
try {
# Parse the metadata
unset -nocomplain state
while {[gets $fd line] >= 0} {
if {[regexp {<(code_set_name|mb_cur_max|mb_cur_min|uconv_class|subchar)>\s+(\S+)} $line -> key val]} {
set state($key) $val
} elseif {[regexp {^\s*CHARMAP\s*$} $line]} {
set state(charmap) ""
break
} else {
# Skip all else
}
}
if {![info exists state(charmap)]} {
abort "Error: $ucmPath has No CHARMAP line."
}
foreach key {code_set_name uconv_class} {
if {[info exists state($key)]} {
set state($key) [string trim $state($key) {"}]
}
}
if {[info exists charMap($encName)]} {
abort "Duplicate file for $encName ($path)"
}
if {![info exists state(uconv_class)]} {
abort "Error: $ucmPath has no uconv_class definition."
}
if {[info exists state(subchar)]} {
# \xNN\xNN.. -> NNNN..
set encSubchar($encName) [string map {\\x {}} $state(subchar)]
}
switch -exact -- $state(uconv_class) {
SBCS {
if {[catch {
parse_SBCS $encName $fd
} result]} {
abort "Could not process $ucmPath. $result"
}
}
default {
log "Skipping $ucmPath -- not SBCS encoding."
return
}
}
} finally {
close $fd
}
}
proc ucm::run {} {
variable encNameMap
variable outputPath
switch [llength $::argv] {
2 {set outputPath [lindex $::argv 1]}
1 {}
default {
abort "Usage: [info nameofexecutable] $::argv0 path/to/icu/ucm/data ?outputfile?"
}
}
foreach {encName fname} [array get encNameMap] {
ucm::parse_file $encName [file join [lindex $::argv 0] ${fname}.ucm]
}
generate_tests
}
ucm::run
|